diff options
-rw-r--r-- | generic/tclBasic.c | 41 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 88 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 222 | ||||
-rw-r--r-- | generic/tclEnsemble.c | 8 | ||||
-rw-r--r-- | generic/tclEvent.c | 6 | ||||
-rw-r--r-- | generic/tclExecute.c | 5 | ||||
-rw-r--r-- | generic/tclIOGT.c | 6 | ||||
-rw-r--r-- | generic/tclIORChan.c | 10 | ||||
-rw-r--r-- | generic/tclInt.h | 3 | ||||
-rw-r--r-- | generic/tclListObj.c | 123 | ||||
-rw-r--r-- | generic/tclObj.c | 119 | ||||
-rw-r--r-- | generic/tclUtil.c | 6 | ||||
-rw-r--r-- | generic/tclVar.c | 6 | ||||
-rw-r--r-- | tests/encoding.test | 2 |
14 files changed, 249 insertions, 396 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7754f71..f207a3e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -812,6 +812,7 @@ Tcl_CreateInterp(void) #endif iPtr->freeProc = NULL; iPtr->errorLine = 0; + iPtr->stubTable = &tclStubs; TclNewObj(iPtr->objResultPtr); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); @@ -904,7 +905,8 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ + TclNewObj(iPtr->emptyObjPtr); + /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); #ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; @@ -1019,12 +1021,6 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ /* - * Initialise the stub table pointer. - */ - - iPtr->stubTable = &tclStubs; - - /* * Initialize the ensemble error message rewriting support. */ @@ -5588,7 +5584,7 @@ TclEvalEx( * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ Tcl_Size line, /* The line the script starts on. */ - int *clNextOuter, /* Information about an outer context for */ + Tcl_Size *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set only in * TclSubstTokens(), to properly handle * [...]-nested commands. The 'outerScript' @@ -5610,7 +5606,8 @@ TclEvalEx( const char *p, *next; const unsigned int minObjs = 20; Tcl_Obj **objv, **objvSpace; - int *expand, *lines, *lineSpace; + int *expand; + Tcl_Size *lines, *lineSpace; Tcl_Token *tokenPtr; int expandRequested, code = TCL_OK; Tcl_Size bytesLeft, commandLength; @@ -5628,10 +5625,10 @@ TclEvalEx( Tcl_Obj **stackObjArray = (Tcl_Obj **) TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); - int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); + Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size)); /* TIP #280 Structures for tracking of command * locations. */ - int *clNext = NULL; /* Pointer for the tracking of invisible + Tcl_Size *clNext = NULL; /* Pointer for the tracking of invisible * continuation lines. Initialized only if the * caller gave us a table of locations to * track, via scriptCLLocPtr. It always refers @@ -5755,7 +5752,7 @@ TclEvalEx( Tcl_Size wordLine = line; const char *wordStart = parsePtr->commandStart; - int *wordCLNext = clNext; + Tcl_Size *wordCLNext = clNext; unsigned int objectsNeeded = 0; unsigned int numWords = parsePtr->numWords; @@ -5766,7 +5763,7 @@ TclEvalEx( if (numWords > minObjs) { expand = (int *)ckalloc(numWords * sizeof(int)); objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (int *)ckalloc(numWords * sizeof(int)); + lineSpace = (Tcl_Size *)ckalloc(numWords * sizeof(Tcl_Size)); } expandRequested = 0; objv = objvSpace; @@ -5846,14 +5843,14 @@ TclEvalEx( */ Tcl_Obj **copy = objvSpace; - int *lcopy = lineSpace; - int wordIdx = numWords; - int objIdx = objectsNeeded - 1; + Tcl_Size *lcopy = lineSpace; + Tcl_Size wordIdx = numWords; + Tcl_Size objIdx = objectsNeeded - 1; if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int)); + lines = lineSpace = (Tcl_Size *)ckalloc(objectsNeeded * sizeof(Tcl_Size)); } objectsUsed = 0; @@ -6088,7 +6085,7 @@ TclAdvanceLines( void TclAdvanceContinuations( Tcl_Size *line, - int **clNextPtrPtr, + Tcl_Size **clNextPtrPtr, int loc) { /* @@ -6266,7 +6263,7 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, - int cmd, + Tcl_Size cmd, Tcl_Size pc) { ExtCmdLoc *eclPtr; @@ -6658,11 +6655,7 @@ TclNREvalObjEx( */ Tcl_IncrRefCount(objPtr); - listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType); - if (!listPtr) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } + listPtr = TclListObjCopy(interp, objPtr); Tcl_IncrRefCount(listPtr); if (word != INT_MIN) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9c9cc26..ea5df68 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -689,11 +689,11 @@ EncodingConvertfromObjCmd( /* NOTE: ds must be freed beyond this point even on error */ switch (result) { case TCL_OK: - errorLocation = TCL_INDEX_NONE; - break; + errorLocation = TCL_INDEX_NONE; + break; case TCL_ERROR: /* Error in parameters. Should not happen. interp will have error */ - Tcl_DStringFree(&ds); + Tcl_DStringFree(&ds); return TCL_ERROR; default: /* @@ -703,10 +703,10 @@ EncodingConvertfromObjCmd( * what could be decoded and the returned error location. */ if (failVarObj == NULL) { - Tcl_DStringFree(&ds); + Tcl_DStringFree(&ds); return TCL_ERROR; } - break; + break; } /* @@ -791,7 +791,7 @@ EncodingConverttoObjCmd( break; case TCL_ERROR: /* Error in parameters. Should not happen. interp will have error */ - Tcl_DStringFree(&ds); + Tcl_DStringFree(&ds); return TCL_ERROR; default: /* @@ -801,10 +801,10 @@ EncodingConverttoObjCmd( * what could be decoded and the returned error location. */ if (failVarObj == NULL) { - Tcl_DStringFree(&ds); + Tcl_DStringFree(&ds); return TCL_ERROR; } - break; + break; } /* * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much @@ -1337,10 +1337,10 @@ FileAttrAccessTimeCmd( #if defined(_WIN32) /* We use a value of 0 to indicate the access time not available */ if (Tcl_GetAccessTimeFromStat(&buf) == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not get access time for file \"%s\"", - TclGetString(objv[1]))); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get access time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; } #endif @@ -1419,10 +1419,10 @@ FileAttrModifyTimeCmd( #if defined(_WIN32) /* We use a value of 0 to indicate the modification time not available */ if (Tcl_GetModificationTimeFromStat(&buf) == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not get modification time for file \"%s\"", - TclGetString(objv[1]))); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get modification time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; } #endif if (objc == 3) { @@ -2462,34 +2462,34 @@ StoreStatData( unsigned short mode; if (varName == NULL) { - TclNewObj(result); - Tcl_IncrRefCount(result); + TclNewObj(result); + Tcl_IncrRefCount(result); #define DOBJPUT(key, objValue) \ Tcl_DictObjPut(NULL, result, \ Tcl_NewStringObj((key), -1), \ (objValue)); - DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); - DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); - DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); - DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); - DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); + DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); + DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); + DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); + DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); + DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); + DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); + DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); + DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif - DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); - DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); - DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); - mode = (unsigned short) statPtr->st_mode; - DOBJPUT("mode", Tcl_NewWideIntObj(mode)); - DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); + DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); + DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); + DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); + mode = (unsigned short) statPtr->st_mode; + DOBJPUT("mode", Tcl_NewWideIntObj(mode)); + DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef DOBJPUT - Tcl_SetObjResult(interp, result); - Tcl_DecrRefCount(result); - return TCL_OK; + Tcl_SetObjResult(interp, result); + Tcl_DecrRefCount(result); + return TCL_OK; } /* @@ -2927,9 +2927,10 @@ EachloopCmd( for (i=0 ; i<numLists ; i++) { /* List */ /* Variables */ - statePtr->vCopyList[i] = TclDuplicatePureObj( - interp, objv[1+i*2], &tclListType); - if (!statePtr->vCopyList[i]) { + + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + statePtr->vCopyList[i] = Tcl_DuplicateObj(objv[1+i*2]); + if (statePtr->vCopyList[i] == NULL) { result = TCL_ERROR; goto done; } @@ -2964,9 +2965,8 @@ EachloopCmd( statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); } else { /* List values */ - statePtr->aCopyList[i] = TclDuplicatePureObj( - interp, objv[2+i*2], &tclListType); - if (!statePtr->aCopyList[i]) { + statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } @@ -3106,9 +3106,9 @@ ForeachAssignments( valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k); if (valuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting %s loop variable \"%s\")", - (statePtr->resultList != NULL ? "lmap" : "foreach"), - TclGetString(statePtr->varvList[i][v]))); + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + TclGetString(statePtr->varvList[i][v]))); return TCL_ERROR; } } else { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index dd8349f..8682c8b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2333,7 +2333,7 @@ Tcl_LassignObjCmd( return TCL_ERROR; } - listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType); + listCopyPtr = TclListObjCopy(interp, objv[1]); if (listCopyPtr == NULL) { return TCL_ERROR; } @@ -2498,10 +2498,7 @@ Tcl_LinsertObjCmd( listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); - if (!listPtr) { - return TCL_ERROR; - } + listPtr = TclListObjCopy(NULL, listPtr); } if ((objc == 4) && (index == len)) { @@ -2688,10 +2685,7 @@ Tcl_LpopObjCmd( if (objc == 2) { if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); - if (!listPtr) { - return TCL_ERROR; - } + listPtr = TclListObjCopy(NULL, listPtr); } result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); if (result != TCL_OK) { @@ -2868,11 +2862,7 @@ Tcl_LremoveObjCmd( */ if (Tcl_IsShared(listObj)) { - listObj = TclDuplicatePureObj(interp, listObj, &tclListType); - if (!listObj) { - status = TCL_ERROR; - goto done; - } + listObj = TclListObjCopy(NULL, listObj); copied = 1; } num = 0; @@ -3124,10 +3114,7 @@ Tcl_LreplaceObjCmd( listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); - if (!listPtr) { - return TCL_ERROR; - } + listPtr = TclListObjCopy(NULL, listPtr); } /* @@ -4018,91 +4005,6 @@ Tcl_LsearchObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_LsetObjCmd -- - * - * This procedure is invoked to process the "lset" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LsetObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument values. */ -{ - Tcl_Obj *listPtr; /* Pointer to the list being altered. */ - Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ - - /* - * Check parameter count. - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); - return TCL_ERROR; - } - - /* - * Look up the list variable's value. - */ - - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { - return TCL_ERROR; - } - - /* - * Substitute the value in the value. Return either the value or else an - * unshared copy of it. - */ - - if (objc == 4) { - finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); - } else { - finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); - } - - /* - * If substitution has failed, bail out. - */ - - if (finalValuePtr == NULL) { - return TCL_ERROR; - } - - /* - * Finally, update the variable so that traces fire. - */ - - listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, - TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(finalValuePtr); - if (listPtr == NULL) { - return TCL_ERROR; - } - - /* - * Return the new value of the variable as the interpreter result. - */ - - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * SequenceIdentifyArgument -- * (for [lseq] command) * @@ -4314,7 +4216,7 @@ Tcl_LseqObjCmd( goto done; break; -/* range n */ +/* lseq n */ case 1: start = zero; elementCount = numValues[0]; @@ -4322,22 +4224,22 @@ Tcl_LseqObjCmd( step = one; break; -/* range n n */ +/* lseq n n */ case 11: start = numValues[0]; end = numValues[1]; break; -/* range n n n */ +/* lseq n n n */ case 111: start = numValues[0]; end = numValues[1]; step = numValues[2]; break; -/* range n 'to' n */ -/* range n 'count' n */ -/* range n 'by' n */ +/* lseq n 'to' n */ +/* lseq n 'count' n */ +/* lseq n 'by' n */ case 121: opmode = (SequenceOperators)values[1]; switch (opmode) { @@ -4362,8 +4264,8 @@ Tcl_LseqObjCmd( } break; -/* range n 'to' n n */ -/* range n 'count' n n */ +/* lseq n 'to' n n */ +/* lseq n 'count' n n */ case 1211: opmode = (SequenceOperators)values[1]; switch (opmode) { @@ -4390,7 +4292,7 @@ Tcl_LseqObjCmd( } break; -/* range n n 'by' n */ +/* lseq n n 'by' n */ case 1121: start = numValues[0]; end = numValues[1]; @@ -4409,8 +4311,8 @@ Tcl_LseqObjCmd( } break; -/* range n 'to' n 'by' n */ -/* range n 'count' n 'by' n */ +/* lseq n 'to' n 'by' n */ +/* lseq n 'count' n 'by' n */ case 12121: start = numValues[0]; opmode = (SequenceOperators)values[3]; @@ -4503,6 +4405,91 @@ Tcl_LseqObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LsetObjCmd -- + * + * This procedure is invoked to process the "lset" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsetObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + Tcl_Obj *listPtr; /* Pointer to the list being altered. */ + Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ + + /* + * Check parameter count. + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "listVar ?index? ?index ...? value"); + return TCL_ERROR; + } + + /* + * Look up the list variable's value. + */ + + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Substitute the value in the value. Return either the value or else an + * unshared copy of it. + */ + + if (objc == 4) { + finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); + } else { + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); + } + + /* + * If substitution has failed, bail out. + */ + + if (finalValuePtr == NULL) { + return TCL_ERROR; + } + + /* + * Finally, update the variable so that traces fire. + */ + + listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(finalValuePtr); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Return the new value of the variable as the interpreter result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LsortObjCmd -- * * This procedure is invoked to process the "lsort" Tcl command. See the @@ -4743,7 +4730,7 @@ Tcl_LsortObjCmd( * 1675116] */ - listObj = TclDuplicatePureObj(interp ,listObj, &tclListType); + listObj = TclListObjCopy(interp, listObj); if (listObj == NULL) { sortInfo.resultCode = TCL_ERROR; goto done; @@ -5101,10 +5088,7 @@ Tcl_LeditObjCmd( } if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); - if (!listPtr) { - return TCL_ERROR; - } + listPtr = TclListObjCopy(NULL, listPtr); createdNewObj = 1; } else { createdNewObj = 0; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 610198c..37531fc 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1900,11 +1900,7 @@ NsEnsembleImplementationCmdNR( TclListObjLengthM(NULL, prefixObj, &prefixObjc); if (objc == 2) { - copyPtr = TclDuplicatePureObj( - interp, prefixObj, &tclListType); - if (!copyPtr) { - return TCL_ERROR; - } + copyPtr = TclListObjCopy(NULL, prefixObj); } else { copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); @@ -3055,7 +3051,7 @@ TclCompileEnsemble( * No map, so check the dictionary directly. */ - TclNewStringObj(subcmdObj, word, (int) numBytes); + TclNewStringObj(subcmdObj, word, numBytes); result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj); if (result == TCL_OK && targetCmdObj != NULL) { /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 5848728..5501721 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -243,11 +243,7 @@ HandleBgErrors( * support one handler setting another handler. */ - Tcl_Obj *copyObj = TclDuplicatePureObj( - interp, assocPtr->cmdPrefix, &tclListType); - if (!copyObj) { - return; - } + Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cb12975..991acfa 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6692,7 +6692,8 @@ TEBCresume( numVars = varListPtr->numVars; listVarPtr = LOCAL(listTmpIndex); - listPtr = TclDuplicatePureObj(NULL, listVarPtr->value.objPtr, &tclListType); + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + listPtr = Tcl_DuplicateObj(listVarPtr->value.objPtr); TclListObjGetElementsM(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); @@ -6789,7 +6790,7 @@ TEBCresume( goto gotError; } if (Tcl_IsShared(listPtr)) { - /* Do NOT use TclDuplicatePureObj here - shimmers abstract list to list */ + /* Do not use TclListObjCopy here - shimmers arithseries to list */ objPtr = Tcl_DuplicateObj(listPtr); if (!objPtr) { goto gotError; diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 77ea6bd..93442a1 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -387,11 +387,7 @@ ExecuteCallback( unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; - Tcl_Obj *command = TclDuplicatePureObj( - interp, dataPtr->command, &tclListType); - if (!command) { - return TCL_ERROR; - } + Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command); Tcl_Interp *eval = dataPtr->interp; Tcl_Preserve(eval); diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 3b1573b..0af76bf 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2285,10 +2285,7 @@ NewReflectedChannel( rcPtr->mode = mode; rcPtr->interest = 0; /* Initially no interest registered */ - rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType); - if (!rcPtr->cmd) { - return NULL; - } + rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj); Tcl_IncrRefCount(rcPtr->cmd); rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL); while (mn <= (int)METH_WRITE) { @@ -2425,10 +2422,7 @@ InvokeTclMethod( * before the channel id. */ - cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType); - if (!cmd) { - return TCL_ERROR; - } + cmd = TclListObjCopy(NULL, rcPtr->cmd); Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj); Tcl_ListObjAppendElement(NULL, cmd, methObj); Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name); diff --git a/generic/tclInt.h b/generic/tclInt.h index a7a9552..e873538 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3142,8 +3142,6 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); -MODULE_SCOPE Tcl_Obj *TclDuplicatePureObj(Tcl_Interp *interp, - Tcl_Obj * objPtr, const Tcl_ObjType *typPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, @@ -3273,6 +3271,7 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n, Tcl_Size *lines, Tcl_Obj *const *elems); +MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, Tcl_Obj *toObj, Tcl_Size elemCount, Tcl_Obj *const elemObjv[]); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index f1b5258..150de6d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1342,6 +1342,47 @@ Tcl_SetListObj( } /* + *---------------------------------------------------------------------- + * + * TclListObjCopy -- + * + * Makes a "pure list" copy of a list value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. + * + * Results: + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * list value as *listPtr does. The returned Tcl_Obj has a refCount of + * zero. If *listPtr does not hold a list, NULL is returned, and if + * interp is non-NULL, an error message is recorded there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjCopy( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj) /* List object for which an element array is + * to be returned. */ +{ + Tcl_Obj *copyObj; + + if (!TclHasInternalRep(listObj, &tclListType)) { + if (SetListFromAny(interp, listObj) != TCL_OK) { + return NULL; + } + } + + TclNewObj(copyObj); + TclInvalidateStringRep(copyObj); + DupListInternalRep(listObj, copyObj); + return copyObj; +} + +/* *------------------------------------------------------------------------ * * ListRepRange -- @@ -2513,7 +2554,6 @@ TclLindexList( Tcl_Obj *indexListCopy; Tcl_Obj **indexObjs; Tcl_Size numIndexObjs; - int status; /* * Determine whether argPtr designates a list or a single index. We have @@ -2531,30 +2571,19 @@ TclLindexList( } /* - * Make a private copy of the index list argument to keep the internal - * representation of the indices array unchanged while it is in use. This - * is probably unnecessary. It does not appear that any damaging change to - * the internal representation is possible, and no test has been devised to - * show any error when this private copy is not made, But it's cheap, and - * it offers some future-proofing insurance in case the TclLindexFlat - * implementation changes in some unexpected way, or some new form of trace - * or callback permits things to happen that the current implementation - * does not. + * Here we make a private copy of the index list argument to avoid any + * shimmering issues that might invalidate the indices array below while + * we are still using it. This is probably unnecessary. It does not appear + * that any damaging shimmering is possible, and no test has been devised + * to show any error when this private copy is not made. But it's cheap, + * and it offers some future-proofing insurance in case the TclLindexFlat + * implementation changes in some unexpected way, or some new form of + * trace or callback permits things to happen that the current + * implementation does not. */ - indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType); - if (!indexListCopy) { - /* - * The argument is neither an index nor a well-formed list. - * Report the error via TclLindexFlat. - * TODO - This is as original code. why not directly return an error? - */ - return TclLindexFlat(interp, listObj, 1, &argObj); - } - status = TclListObjGetElementsM( - interp, indexListCopy, &numIndexObjs, &indexObjs); - if (status != TCL_OK) { - Tcl_DecrRefCount(indexListCopy); + indexListCopy = TclListObjCopy(NULL, argObj); + if (indexListCopy == NULL) { /* * The argument is neither an index nor a well-formed list. * Report the error via TclLindexFlat. @@ -2562,6 +2591,7 @@ TclLindexList( */ return TclLindexFlat(interp, listObj, 1, &argObj); } + TclListObjGetElementsM(interp, indexListCopy, &numIndexObjs, &indexObjs); listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs); Tcl_DecrRefCount(indexListCopy); return listObj; @@ -2744,8 +2774,7 @@ TclLsetList( } else { - indexListCopy = TclDuplicatePureObj( - interp, indexArgObj, &tclListType); + indexListCopy = TclListObjCopy(NULL,indexArgObj); if (!indexListCopy) { /* * indexArgPtr designates something that is neither an index nor a @@ -2823,7 +2852,7 @@ TclLsetFlat( Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { Tcl_Size index, len; - int copied = 0, result; + int result; Tcl_Obj *subListObj, *retValueObj; Tcl_Obj *pendingInvalidates[10]; Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates; @@ -2843,15 +2872,17 @@ TclLsetFlat( } /* - * If the list is shared, make a copy to modify (copy-on-write). The string - * representation and internal representation of listObj remains unchanged. + * If the list is shared, make a copy we can modify (copy-on-write). We + * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: + * 1) we have not yet confirmed listObj is actually a list; 2) We make a + * verbatim copy of any existing string rep, and when we combine that with + * the delayed invalidation of string reps of modified Tcl_Obj's + * implemented below, the outcome is that any error condition that causes + * this routine to return NULL, will leave the string rep of listObj and + * all elements to be unchanged. */ - subListObj = Tcl_IsShared(listObj) - ? TclDuplicatePureObj(interp, listObj, &tclListType) : listObj; - if (!subListObj) { - return NULL; - } + subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj; /* * Anchor the linked list of Tcl_Obj's whose string reps must be @@ -2924,9 +2955,10 @@ TclLsetFlat( } /* - * No error conditions. If this is not the last index, determine the - * next sublist for the next pass through the loop, and take steps to - * make sure it is unshared in order to modify it. + * No error conditions. As long as we're not yet on the last index, + * determine the next sublist for the next pass through the loop, + * and take steps to make sure it is an unshared copy, as we intend + * to modify it. */ if (--indexCount) { @@ -2937,12 +2969,7 @@ TclLsetFlat( subListObj = elemPtrs[index]; } if (Tcl_IsShared(subListObj)) { - subListObj = TclDuplicatePureObj( - interp, subListObj, &tclListType); - if (!subListObj) { - return NULL; - } - copied = 1; + subListObj = Tcl_DuplicateObj(subListObj); } /* @@ -2960,17 +2987,7 @@ TclLsetFlat( TclListObjSetElement(NULL, parentList, index, subListObj); } if (Tcl_IsShared(subListObj)) { - Tcl_Obj * newSubListObj; - newSubListObj = TclDuplicatePureObj( - interp, subListObj, &tclListType); - if (copied) { - Tcl_DecrRefCount(subListObj); - } - if (newSubListObj) { - subListObj = newSubListObj; - } else { - return NULL; - } + subListObj = Tcl_DuplicateObj(subListObj); TclListObjSetElement(NULL, parentList, index, subListObj); } diff --git a/generic/tclObj.c b/generic/tclObj.c index 96ad9e6..d440f9f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -205,9 +205,6 @@ static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int copy, mp_int *bignumValue); -static int SetDuplicatePureObj(Tcl_Interp *interp, - Tcl_Obj *dupPtr, Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr); /* * Prototypes for the array hash key methods. @@ -1545,14 +1542,6 @@ TclObjBeingDeleted( * Create and return a new object that is a duplicate of the argument * object. * - * TclDuplicatePureObj -- - * Like Tcl_DuplicateObj, except that it converts the duplicate to the - * specifid typ, does not duplicate the 'bytes' - * field unless it is necessary, i.e. the duplicated Tcl_Obj provides no - * updateStringProc. This can avoid an expensive memory allocation since - * the data in the 'bytes' field of each Tcl_Obj must reside in allocated - * memory. - * * Results: * The return value is a pointer to a newly created Tcl_Obj. This object * has reference count 0 and the same type, if any, as the source object @@ -1604,114 +1593,6 @@ Tcl_DuplicateObj( return dupPtr; } - -/* - *---------------------------------------------------------------------- - * - * TclDuplicatePureObj -- - * - * Duplicates a Tcl_Obj and converts the internal representation of the - * duplicate to the given type, changing neither the 'bytes' field - * nor the internal representation of the original object, and without - * duplicating the bytes field unless necessary, i.e. unless the - * duplicate provides no updateStringProc after conversion. This can - * avoid an expensive memory allocation since the data in the 'bytes' - * field of each Tcl_Obj must reside in allocated memory. - * - * Results: - * A pointer to a newly-created Tcl_Obj or NULL if there was an error. - * This object has reference count 0. Also: - * - *---------------------------------------------------------------------- - */ -int SetDuplicatePureObj( - Tcl_Interp *interp, - Tcl_Obj *dupPtr, - Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr) -{ - char *bytes = objPtr->bytes; - int status = TCL_OK; - - TclInvalidateStringRep(dupPtr); - assert(dupPtr->typePtr == NULL); - - if (objPtr->typePtr && objPtr->typePtr->dupIntRepProc) { - objPtr->typePtr->dupIntRepProc(objPtr, dupPtr); - } else { - dupPtr->internalRep = objPtr->internalRep; - dupPtr->typePtr = objPtr->typePtr; - } - - if (typePtr != NULL && dupPtr->typePtr != typePtr) { - if (bytes) { - dupPtr->bytes = bytes; - dupPtr->length = objPtr->length; - } - /* borrow bytes from original object */ - status = Tcl_ConvertToType(interp, dupPtr, typePtr); - if (bytes) { - dupPtr->bytes = NULL; - dupPtr->length = 0; - } - if (status != TCL_OK) { - return status; - } - } - - /* tclUniCharStringType is treated as a special case because a Tcl_Obj having this - * type can not always update the string representation. This happens, for - * example, when Tcl_GetCharLength() converts the internal representation - * to tclUniCharStringType in order to store the number of characters, but does - * not store enough information to generate the string representation. - * - * Perhaps in the future this can be remedied and this special treatment - * removed. - * - * Similar problem with the integer (0x0A vs 10), double (1e-1 vs 0.1) and - * index types ("coord" vs "coords", see bug [a34733451b]) - */ - - - if (bytes && (dupPtr->typePtr == NULL - || dupPtr->typePtr->updateStringProc == NULL - || objPtr->typePtr == &tclUniCharStringType - ) - ) { - if (!TclAttemptInitStringRep(dupPtr, bytes, objPtr->length)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "insufficient memory to initialize string", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - status = TCL_ERROR; - } - } - return status; -} - -Tcl_Obj * -TclDuplicatePureObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr -) /* The object to duplicate. */ -{ - int status; - Tcl_Obj *dupPtr; - - TclNewObj(dupPtr); - status = SetDuplicatePureObj(interp, dupPtr, objPtr, typePtr); - if (status == TCL_OK) { - return dupPtr; - } else { - Tcl_DecrRefCount(dupPtr); - return NULL; - } -} - - - void TclSetDuplicateObj( Tcl_Obj *dupPtr, diff --git a/generic/tclUtil.c b/generic/tclUtil.c index cfc56b0..f9f6ae0 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2051,11 +2051,7 @@ Tcl_ConcatObj( goto slow; } } else { - resPtr = TclDuplicatePureObj( - NULL, objPtr, &tclListType); - if (!resPtr) { - return NULL; - } + resPtr = TclListObjCopy(NULL, objPtr); } } if (!resPtr) { diff --git a/generic/tclVar.c b/generic/tclVar.c index 70ba63b..4110d81 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3221,7 +3221,8 @@ ArrayForNRCmd( * loop) don't vanish. */ - varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType); + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + varListObj = Tcl_DuplicateObj(objv[1]); if (!varListObj) { return TCL_ERROR; } @@ -4196,8 +4197,7 @@ ArraySetCmd( * the loop and return an error. */ - copyListObj = - TclDuplicatePureObj(interp, arrayElemObj, &tclListType); + copyListObj = TclListObjCopy(NULL, arrayElemObj); if (!copyListObj) { return TCL_ERROR; } diff --git a/tests/encoding.test b/tests/encoding.test index 72cc964..da2dac3 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1075,7 +1075,7 @@ test encoding-bug-183a1adcc0-4 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExtern } -result [list 0 [list nospace {} \x00\x00\xFF]] test encoding-bug-183a1adcc0-5 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints { - testencoding + testencoding } -body { list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 4} result] $result } -result [list 0 [list ok {} [expr {$::tcl_platform(byteOrder) eq "littleEndian" ? "\x41\x00" : "\x00\x41"}]\x00\x00]] |