tcltk/tcl
1
0
Fork 0
mirror of https://github.com/tcltk/tcl.git synced 2026-05-29 00:27:49 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge "revert-dup-pure" branch: get rid of TclDuplicatePureObj()

Browse Source
This commit is contained in:
jan.nijtmans
2023-08-25 15:14:18 +00:00
parent 4408536018 65f03434ca
commit b5fb869a2d
14 changed files with 249 additions and 396 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
generic/tclBasic.c
View File

@@ -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;
@@ -1018,12 +1020,6 @@ Tcl_CreateInterp(void)
memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
#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) {

88
generic/tclCmdAH.c
View File

@@ -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 {

222
generic/tclCmdIL.c
View File

@@ -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);
}
/*
@@ -4015,91 +4002,6 @@ Tcl_LsearchObjCmd(
return result;
}
/*
*----------------------------------------------------------------------
*
* 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;
}
/*
*----------------------------------------------------------------------
*
@@ -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];
@@ -4500,6 +4402,91 @@ Tcl_LseqObjCmd(
return status;
}
/*
*----------------------------------------------------------------------
*
* 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;
}
/*
*----------------------------------------------------------------------
*
@@ -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;

8
generic/tclEnsemble.c
View File

@@ -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) {
/*

6
generic/tclEvent.c
View File

@@ -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;

5
generic/tclExecute.c
View File

@@ -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;

6
generic/tclIOGT.c
View File

@@ -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);

10
generic/tclIORChan.c
View File

@@ -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);

3
generic/tclInt.h
View File

@@ -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[]);

123
generic/tclListObj.c
View File

@@ -1341,6 +1341,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;
}
/*
*------------------------------------------------------------------------
*
@@ -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);
}

119
generic/tclObj.c
View File

@@ -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,

6
generic/tclUtil.c
View File

@@ -2051,11 +2051,7 @@ Tcl_ConcatObj(
goto slow;
}
} else {
resPtr = TclDuplicatePureObj(
NULL, objPtr, &tclListType);
if (!resPtr) {
return NULL;
}
resPtr = TclListObjCopy(NULL, objPtr);
}
}
if (!resPtr) {

6
generic/tclVar.c
View File

@@ -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;
}

2
tests/encoding.test
View File

@@ -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]]