summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/regexec.c66
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclBinary.c10
-rw-r--r--generic/tclClock.c4
-rw-r--r--generic/tclCmdIL.c6
-rw-r--r--generic/tclEnsemble.c14
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclIO.c5
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclInterp.c2
-rw-r--r--generic/tclLink.c33
-rw-r--r--generic/tclListObj.c140
-rw-r--r--generic/tclProc.c17
-rw-r--r--generic/tclStrToD.c88
-rw-r--r--generic/tclTest.c84
-rw-r--r--generic/tclUtf.c6
-rw-r--r--generic/tclZipfs.c2
17 files changed, 310 insertions, 183 deletions
diff --git a/generic/regexec.c b/generic/regexec.c
index 40839b1..7b84f0f 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -232,13 +232,15 @@ exec(
v->err = 0;
assert(v->g->ntree >= 0);
n = v->g->ntree;
- if (n <= LOCALDFAS)
+ if (n <= LOCALDFAS) {
v->subdfas = subdfas;
- else
+ } else {
v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *));
+ }
if (v->subdfas == NULL) {
- if (v->pmatch != pmatch && v->pmatch != mat)
+ if (v->pmatch != pmatch && v->pmatch != mat) {
FREE(v->pmatch);
+ }
FreeVars(v);
return REG_ESPACE;
}
@@ -275,11 +277,13 @@ exec(
}
n = v->g->ntree;
for (i = 0; i < n; i++) {
- if (v->subdfas[i] != NULL)
+ if (v->subdfas[i] != NULL) {
freeDFA(v->subdfas[i]);
+ }
}
- if (v->subdfas != subdfas)
+ if (v->subdfas != subdfas) {
FREE(v->subdfas);
+ }
FreeVars(v);
return st;
}
@@ -295,8 +299,9 @@ getsubdfa(struct vars * v,
{
if (v->subdfas[t->id] == NULL) {
v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, NULL);
- if (ISERR())
+ if (ISERR()) {
return NULL;
+ }
}
return v->subdfas[t->id];
}
@@ -636,10 +641,11 @@ cdissect(
break;
case '.': /* concatenation */
assert(t->left != NULL && t->right != NULL);
- if (t->left->flags & SHORTER) /* reverse scan */
+ if (t->left->flags & SHORTER) {/* reverse scan */
er = crevcondissect(v, t, begin, end);
- else
+ } else {
er = ccondissect(v, t, begin, end);
+ }
break;
case '|': /* alternation */
assert(t->left != NULL);
@@ -647,10 +653,11 @@ cdissect(
break;
case '*': /* iteration */
assert(t->left != NULL);
- if (t->left->flags & SHORTER) /* reverse scan */
+ if (t->left->flags & SHORTER) {/* reverse scan */
er = creviterdissect(v, t, begin, end);
- else
+ } else {
er = citerdissect(v, t, begin, end);
+ }
break;
case '(': /* capturing */
assert(t->left != NULL && t->right == NULL);
@@ -916,17 +923,20 @@ cbrdissect(
assert(end > begin);
tlen = end - begin;
- if (tlen % brlen != 0)
+ if (tlen % brlen != 0) {
return REG_NOMATCH;
+ }
numreps = tlen / brlen;
- if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF))
+ if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF)) {
return REG_NOMATCH;
+ }
/* okay, compare the actual string contents */
p = begin;
while (numreps-- > 0) {
- if ((*v->g->compare) (brstring, p, brlen) != 0)
+ if ((*v->g->compare) (brstring, p, brlen) != 0) {
return REG_NOMATCH;
+ }
p += brlen;
}
@@ -1003,8 +1013,9 @@ citerdissect(struct vars * v,
*/
min_matches = t->min;
if (min_matches <= 0) {
- if (begin == end)
+ if (begin == end) {
return REG_OKAY;
+ }
min_matches = 1;
}
@@ -1018,8 +1029,9 @@ citerdissect(struct vars * v,
* sub-match endpoints in endpts[1..max_matches].
*/
max_matches = end - begin;
- if (max_matches > (size_t)t->max && t->max != DUPINF)
+ if (max_matches > (size_t)t->max && t->max != DUPINF) {
max_matches = t->max;
+ }
if (max_matches < (size_t)min_matches)
max_matches = min_matches;
endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *));
@@ -1062,8 +1074,9 @@ citerdissect(struct vars * v,
t->id, k, LOFF(endpts[k])));
/* k'th sub-match can no longer be considered verified */
- if (nverified >= k)
+ if (nverified >= k) {
nverified = k - 1;
+ }
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
@@ -1089,8 +1102,9 @@ citerdissect(struct vars * v,
* number of matches, start the slow part: recurse to verify each
* sub-match. We always have k <= max_matches, needn't check that.
*/
- if (k < min_matches)
+ if (k < min_matches) {
goto backtrack;
+ }
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
@@ -1101,8 +1115,9 @@ citerdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
@@ -1176,8 +1191,9 @@ creviterdissect(struct vars * v,
*/
min_matches = t->min;
if (min_matches <= 0) {
- if (begin == end)
+ if (begin == end) {
return REG_OKAY;
+ }
min_matches = 1;
}
@@ -1231,8 +1247,9 @@ creviterdissect(struct vars * v,
limit++;
/* if this is the last allowed sub-match, it must reach to the end */
- if ((size_t)k >= max_matches)
+ if ((size_t)k >= max_matches) {
limit = end;
+ }
/* try to find an endpoint for the k'th sub-match */
endpts[k] = shortest(v, d, endpts[k - 1], limit, end,
@@ -1246,8 +1263,9 @@ creviterdissect(struct vars * v,
t->id, k, LOFF(endpts[k])));
/* k'th sub-match can no longer be considered verified */
- if (nverified >= k)
+ if (nverified >= k) {
nverified = k - 1;
+ }
if (endpts[k] != end) {
/* haven't reached end yet, try another iteration if allowed */
@@ -1268,8 +1286,9 @@ creviterdissect(struct vars * v,
* number of matches, start the slow part: recurse to verify each
* sub-match. We always have k <= max_matches, needn't check that.
*/
- if (k < min_matches)
+ if (k < min_matches) {
goto backtrack;
+ }
MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k));
@@ -1280,8 +1299,9 @@ creviterdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index ea7726b..d73c749 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -3016,7 +3016,7 @@ TclRenameCommand(
}
cmdNsPtr = cmdPtr->nsPtr;
- oldFullName = Tcl_NewObj();
+ TclNewObj(oldFullName);
Tcl_IncrRefCount(oldFullName);
Tcl_GetCommandFullName(interp, cmd, oldFullName);
@@ -5025,7 +5025,7 @@ TclEvalEx(
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
- size_t i, objectsUsed = 0;
+ TCL_HASH_TYPE i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 90efc9f..a7d6617 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -341,7 +341,7 @@ Tcl_SetByteArrayObj(
*
* Attempt to extract the value from objPtr in the representation
* of a byte sequence. On success return the extracted byte sequence.
- * On failures, return NULL and record error message and code in
+ * On failure, return NULL and record error message and code in
* interp (if not NULL).
*
* Results:
@@ -872,8 +872,7 @@ BinaryFormatCmd(
* cursor has visited.*/
const char *errorString;
const char *errorValue, *str;
- size_t offset, size;
- size_t length;
+ size_t offset, size, length;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?");
@@ -1379,8 +1378,7 @@ BinaryScanCmd(
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
- size_t offset, size, i;
- size_t length = 0;
+ size_t offset, size, length = 0, i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
@@ -1656,7 +1654,7 @@ BinaryScanCmd(
if (count == BINARY_NOCOUNT) {
count = 1;
}
- if ((count == BINARY_ALL) || (count > length - offset)) {
+ if ((count == BINARY_ALL) || (count > (length - offset))) {
offset = length;
} else {
offset += count;
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 2175ed9..075c65b 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -1520,9 +1520,9 @@ GetJulianDayFromEraYearMonthDay(
* Have to make sure quotient is truncated towards 0 when negative.
* See above bug for details. The casts are necessary.
*/
- if (ym1 >= 0)
+ if (ym1 >= 0) {
ym1o4 = ym1 / 4;
- else {
+ } else {
ym1o4 = - (int) (((unsigned int) -ym1) / 4);
}
#endif
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 351acf9..f59d832 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2904,7 +2904,7 @@ Tcl_LrepeatObjCmd(
List *listRepPtr = ListRepPtr(listPtr);
listRepPtr->elemCount = elementCount*objc;
- dataArray = &listRepPtr->elements;
+ dataArray = listRepPtr->elements;
}
/*
@@ -3091,7 +3091,7 @@ Tcl_LreverseObjCmd(
resultObj = Tcl_NewListObj(elemc, NULL);
listRepPtr = ListRepPtr(resultObj);
listRepPtr->elemCount = elemc;
- dataArray = &listRepPtr->elements;
+ dataArray = listRepPtr->elements;
for (i=0,j=elemc-1 ; i<elemc ; i++,j--) {
dataArray[j] = elemv[i];
@@ -4424,7 +4424,7 @@ Tcl_LsortObjCmd(
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
listRepPtr = ListRepPtr(resultPtr);
- newArray = &listRepPtr->elements;
+ newArray = listRepPtr->elements;
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 2220896..8bb90da 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -21,12 +21,12 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
EnsembleConfig *ensemblePtr, int objc,
Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
-static int NsEnsembleImplementationCmdNR(ClientData clientData,
+static int NsEnsembleImplementationCmdNR(void *clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
static int NsEnsembleStringOrder(const void *strPtr1,
const void *strPtr2);
-static void DeleteEnsembleConfig(ClientData clientData);
+static void DeleteEnsembleConfig(void *clientData);
static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
Tcl_Obj *fix);
@@ -1682,7 +1682,7 @@ TclMakeEnsemble(
int
TclEnsembleImplementationCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1693,7 +1693,7 @@ TclEnsembleImplementationCmd(
static int
NsEnsembleImplementationCmdNR(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1988,7 +1988,7 @@ NsEnsembleImplementationCmdNR(
int
TclClearRootEnsemble(
- TCL_UNUSED(ClientData *),
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -2094,7 +2094,7 @@ TclResetRewriteEnsemble(
static int
FreeER(
- ClientData data[],
+ void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
@@ -2491,7 +2491,7 @@ ClearTable(
static void
DeleteEnsembleConfig(
- ClientData clientData)
+ void *clientData)
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 32958fb..c8d2869 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2750,7 +2750,7 @@ TEBCresume(
pc += 1;
/* yield next instruction */
TEBC_YIELD();
- /* add TEBCresume for object at top of stack */
+ /* add TEBCResume for object at top of stack */
return TclNRExecuteByteCode(interp,
TclCompileObj(interp, OBJ_AT_TOS, NULL, 0));
@@ -4452,7 +4452,7 @@ TEBCresume(
TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
O2S(valuePtr)));
- for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
+ for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
miPtr = contextPtr->callPtr->chain + i;
if (miPtr->isFilter
|| miPtr->mPtr->declaringClassPtr != classPtr) {
diff --git a/generic/tclIO.c b/generic/tclIO.c
index b1286de..80780d7 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4717,7 +4717,6 @@ Tcl_GetsObj(
eol = dst;
skip = 1;
if (GotFlag(statePtr, INPUT_SAW_CR)) {
- ResetFlag(statePtr, INPUT_SAW_CR);
if ((eol < dstEnd) && (*eol == '\n')) {
/*
* Skip the raw bytes that make up the '\n'.
@@ -4767,8 +4766,10 @@ Tcl_GetsObj(
skip++;
}
eol--;
+ ResetFlag(statePtr, INPUT_SAW_CR);
goto gotEOL;
} else if (*eol == '\n') {
+ ResetFlag(statePtr, INPUT_SAW_CR);
goto gotEOL;
}
}
@@ -4797,7 +4798,7 @@ Tcl_GetsObj(
Tcl_SetObjLength(objPtr, oldLength);
CommonGetsCleanup(chanPtr);
copiedTotal = -1;
- ResetFlag(statePtr, CHANNEL_BLOCKED);
+ ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR);
goto done;
}
goto gotEOL;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 394fc54..69b18b1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2396,14 +2396,14 @@ typedef struct List {
* derived from the list representation. May
* be ignored if there is no string rep at
* all.*/
- Tcl_Obj *elements; /* First list element; the struct is grown to
+ Tcl_Obj *elements[TCLFLEXARRAY]; /* First list element; the struct is grown to
* accommodate all elements. */
} List;
#define LIST_MAX \
- (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
+ ((int)(((size_t)UINT_MAX - offsetof(List, elements))/sizeof(Tcl_Obj *)))
#define LIST_SIZE(numElems) \
- (sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))
+ (TCL_HASH_TYPE)(offsetof(List, elements) + ((numElems) * sizeof(Tcl_Obj *)))
/*
* Macro used to get the elements of a list object.
@@ -2413,7 +2413,7 @@ typedef struct List {
((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
#define ListObjGetElements(listPtr, objc, objv) \
- ((objv) = &(ListRepPtr(listPtr)->elements), \
+ ((objv) = ListRepPtr(listPtr)->elements, \
(objc) = ListRepPtr(listPtr)->elemCount)
#define ListObjLength(listPtr, len) \
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index fd3264f..d368829 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1844,7 +1844,7 @@ AliasNRCmd(
listPtr = Tcl_NewListObj(cmdc, NULL);
listRep = ListRepPtr(listPtr);
listRep->elemCount = cmdc;
- cmdv = &listRep->elements;
+ cmdv = listRep->elements;
prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, (prefc * sizeof(Tcl_Obj *)));
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 839cc0c..2649d12 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -95,7 +95,7 @@ typedef struct {
* Forward references to functions defined later in this file:
*/
-static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
+static char * LinkTraceProc(void *clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
static void LinkFree(Link *linkPtr);
@@ -527,7 +527,7 @@ GetUWide(
Tcl_WideUInt *uwidePtr)
{
Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr;
- ClientData clientData;
+ void *clientData;
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
@@ -631,8 +631,9 @@ SetInvalidRealFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
+ const char *str;
+ const char *endPtr;
size_t length;
- const char *str, *endPtr;
str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 1) && (str[0] == '.')) {
@@ -643,8 +644,8 @@ SetInvalidRealFromAny(
if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
/*
- * If number is followed by [eE][+-]?, then it is an invalid double,
- * but it could be the start of a valid double.
+ * If number is followed by [eE][+-]?, then it is an invalid
+ * double, but it could be the start of a valid double.
*/
if (*endPtr == 'e' || *endPtr == 'E') {
@@ -667,10 +668,10 @@ SetInvalidRealFromAny(
}
/*
- * This function checks for integer representations, which are valid when
- * linking with C variables, but which are invalid in other contexts in Tcl.
- * Handled are "+", "-", "", "0x", "0b", "0d" and "0o" (upper- and
- * lower-case). See bug [39f6304c2e].
+ * This function checks for integer representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
+ * (upperand lowercase). See bug [39f6304c2e].
*/
static int
@@ -681,8 +682,8 @@ GetInvalidIntFromObj(
size_t length;
const char *str = Tcl_GetStringFromObj(objPtr, &length);
- if ((length == 0) ||
- ((length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) {
+ if ((length == 0) || ((length == 2) && (str[0] == '0')
+ && strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((length == 1) && strchr("+-", str[0])) {
@@ -693,10 +694,10 @@ GetInvalidIntFromObj(
}
/*
- * This function checks for double representations, which are valid when
- * linking with C variables, but which are invalid in other contexts in Tcl.
- * Handled are "+", "-", "", ".", "0x", "0b" and "0o" (upper- and lower-case)
- * and sequences like "1e-". See bug [39f6304c2e].
+ * This function checks for double representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
+ * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
*/
static int
@@ -744,7 +745,7 @@ GetInvalidDoubleFromObj(
static char *
LinkTraceProc(
- ClientData clientData, /* Contains information about the link. */
+ void *clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 0690219..b0a21ca 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -20,7 +20,7 @@
static List * AttemptNewList(Tcl_Interp *interp, size_t objc,
Tcl_Obj *const objv[]);
-static List * NewListIntRep(size_t objc, Tcl_Obj *const objv[], size_t p);
+static List * NewListInternalRep(size_t objc, Tcl_Obj *const objv[], size_t p);
static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeListInternalRep(Tcl_Obj *listPtr);
static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -49,7 +49,7 @@ const Tcl_ObjType tclListType = {
/* Macros to manipulate the List internal rep */
-#define ListSetIntRep(objPtr, listRepPtr) \
+#define ListSetInternalRep(objPtr, listRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (listRepPtr); \
@@ -58,14 +58,14 @@ const Tcl_ObjType tclListType = {
Tcl_StoreInternalRep((objPtr), &tclListType, &ir); \
} while (0)
-#define ListGetIntRep(objPtr, listRepPtr) \
+#define ListGetInternalRep(objPtr, listRepPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclListType); \
(listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
-#define ListResetIntRep(objPtr, listRepPtr) \
+#define ListResetInternalRep(objPtr, listRepPtr) \
TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr)
#ifndef TCL_MIN_ELEMENT_GROWTH
@@ -75,7 +75,7 @@ const Tcl_ObjType tclListType = {
/*
*----------------------------------------------------------------------
*
- * NewListIntRep --
+ * NewListInternalRep --
*
* Creates a 'List' structure with space for 'objc' elements. 'objc' must
* be > 0. If 'objv' is not NULL, The list is initialized with first
@@ -98,7 +98,7 @@ const Tcl_ObjType tclListType = {
*/
static List *
-NewListIntRep(
+NewListInternalRep(
size_t objc,
Tcl_Obj *const objv[],
size_t p)
@@ -123,7 +123,7 @@ NewListIntRep(
size_t i;
listRepPtr->elemCount = objc;
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
for (i = 0; i < objc; i++) {
elemPtrs[i] = objv[i];
Tcl_IncrRefCount(elemPtrs[i]);
@@ -139,7 +139,7 @@ NewListIntRep(
*
* AttemptNewList --
*
- * Like NewListIntRep, but additionally sets an error message on failure.
+ * Like NewListInternalRep, but additionally sets an error message on failure.
*
*----------------------------------------------------------------------
*/
@@ -150,7 +150,7 @@ AttemptNewList(
size_t objc,
Tcl_Obj *const objv[])
{
- List *listRepPtr = NewListIntRep(objc, objv, 0);
+ List *listRepPtr = NewListInternalRep(objc, objv, 0);
if (interp != NULL && listRepPtr == NULL) {
if (objc > LIST_MAX) {
@@ -221,14 +221,14 @@ Tcl_NewListObj(
* Create the internal rep.
*/
- listRepPtr = NewListIntRep(objc, objv, 1);
+ listRepPtr = NewListInternalRep(objc, objv, 1);
/*
* Now create the object.
*/
TclInvalidateStringRep(listPtr);
- ListSetIntRep(listPtr, listRepPtr);
+ ListSetInternalRep(listPtr, listRepPtr);
return listPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -272,14 +272,14 @@ Tcl_DbNewListObj(
* Create the internal rep.
*/
- listRepPtr = NewListIntRep(objc, objv, 1);
+ listRepPtr = NewListInternalRep(objc, objv, 1);
/*
* Now create the object.
*/
TclInvalidateStringRep(listPtr);
- ListSetIntRep(listPtr, listRepPtr);
+ ListSetInternalRep(listPtr, listRepPtr);
return listPtr;
}
@@ -334,8 +334,8 @@ Tcl_SetListObj(
*/
if (objc > 0) {
- listRepPtr = NewListIntRep(objc, objv, 1);
- ListSetIntRep(objPtr, listRepPtr);
+ listRepPtr = NewListInternalRep(objc, objv, 1);
+ ListSetInternalRep(objPtr, listRepPtr);
} else {
Tcl_InitStringRep(objPtr, NULL, 0);
}
@@ -373,7 +373,7 @@ TclListObjCopy(
Tcl_Obj *copyPtr;
List *listRepPtr;
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (NULL == listRepPtr) {
if (SetListFromAny(interp, listPtr) != TCL_OK) {
return NULL;
@@ -412,8 +412,7 @@ TclListObjRange(
size_t toIdx) /* Index of last element to include. */
{
Tcl_Obj **elemPtrs;
- size_t listLen;
- size_t i, newLen;
+ size_t listLen, i, newLen;
List *listRepPtr;
TclListObjGetElementsM(NULL, listPtr, &listLen, &elemPtrs);
@@ -516,7 +515,7 @@ Tcl_ListObjGetElements(
{
List *listRepPtr;
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
@@ -532,10 +531,10 @@ Tcl_ListObjGetElements(
if (result != TCL_OK) {
return result;
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
}
*objcPtr = listRepPtr->elemCount;
- *objvPtr = &listRepPtr->elements;
+ *objvPtr = listRepPtr->elements;
return TCL_OK;
}
@@ -642,7 +641,7 @@ Tcl_ListObjAppendElement(
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
@@ -656,7 +655,7 @@ Tcl_ListObjAppendElement(
if (result != TCL_OK) {
return result;
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
}
numElems = listRepPtr->elemCount;
@@ -701,7 +700,7 @@ Tcl_ListObjAppendElement(
}
}
if (isShared || needGrow) {
- Tcl_Obj **dst, **src = &listRepPtr->elements;
+ Tcl_Obj **dst, **src = listRepPtr->elements;
/*
* Either we have a shared internalrep and we must copy to write, or we
@@ -729,7 +728,7 @@ Tcl_ListObjAppendElement(
return TCL_ERROR;
}
- dst = &newPtr->elements;
+ dst = newPtr->elements;
newPtr->refCount++;
newPtr->canonicalFlag = listRepPtr->canonicalFlag;
newPtr->elemCount = listRepPtr->elemCount;
@@ -754,10 +753,10 @@ Tcl_ListObjAppendElement(
}
listRepPtr = newPtr;
}
- ListResetIntRep(listPtr, listRepPtr);
+ ListResetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount++;
TclFreeInternalRep(listPtr);
- ListSetIntRep(listPtr, listRepPtr);
+ ListSetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount--;
/*
@@ -765,7 +764,7 @@ Tcl_ListObjAppendElement(
* the ref count for the (now shared) objPtr.
*/
- *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;
+ listRepPtr->elements[listRepPtr->elemCount] = objPtr;
Tcl_IncrRefCount(objPtr);
listRepPtr->elemCount++;
@@ -817,7 +816,7 @@ Tcl_ListObjIndex(
{
List *listRepPtr;
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
@@ -831,13 +830,13 @@ Tcl_ListObjIndex(
if (result != TCL_OK) {
return result;
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
}
if (index >= listRepPtr->elemCount) {
*objPtrPtr = NULL;
} else {
- *objPtrPtr = (&listRepPtr->elements)[index];
+ *objPtrPtr = listRepPtr->elements[index];
}
return TCL_OK;
@@ -871,11 +870,11 @@ int
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object whose #elements to return. */
- size_t *intPtr) /* The resulting size_t is stored here. */
+ size_t *intPtr) /* The resulting length is stored here. */
{
List *listRepPtr;
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
@@ -889,7 +888,7 @@ Tcl_ListObjLength(
if (result != TCL_OK) {
return result;
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
}
*intPtr = listRepPtr->elemCount;
@@ -954,7 +953,7 @@ Tcl_ListObjReplace(
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
size_t length;
@@ -971,7 +970,7 @@ Tcl_ListObjReplace(
return result;
}
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
}
/*
@@ -982,7 +981,7 @@ Tcl_ListObjReplace(
* Resist any temptation to optimize this case.
*/
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
if (first == TCL_INDEX_NONE) {
@@ -1027,8 +1026,8 @@ Tcl_ListObjReplace(
}
if (newPtr) {
listRepPtr = newPtr;
- ListResetIntRep(listPtr, listRepPtr);
- elemPtrs = &listRepPtr->elements;
+ ListResetInternalRep(listPtr, listRepPtr);
+ elemPtrs = listRepPtr->elements;
listRepPtr->maxElemCount = attempt;
needGrow = numRequired > listRepPtr->maxElemCount;
}
@@ -1096,10 +1095,10 @@ Tcl_ListObjReplace(
}
}
- ListResetIntRep(listPtr, listRepPtr);
+ ListResetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount++;
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
if (isShared) {
/*
@@ -1175,7 +1174,7 @@ Tcl_ListObjReplace(
listRepPtr->refCount++;
TclFreeInternalRep(listPtr);
- ListSetIntRep(listPtr, listRepPtr);
+ ListSetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount--;
TclInvalidateStringRep(listPtr);
@@ -1221,7 +1220,7 @@ TclLindexList(
* shimmering; see TIP#22 and TIP#33 for the details.
*/
- ListGetIntRep(argPtr, listRepPtr);
+ ListGetInternalRep(argPtr, listRepPtr);
if ((listRepPtr == NULL)
&& TclGetIntForIndexM(NULL , argPtr, (size_t)WIDE_MAX - 1, &index) == TCL_OK) {
/*
@@ -1253,12 +1252,12 @@ TclLindexList(
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
- ListGetIntRep(indexListCopy, listRepPtr);
+ ListGetInternalRep(indexListCopy, listRepPtr);
assert(listRepPtr != NULL);
listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
- &listRepPtr->elements);
+ listRepPtr->elements);
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
@@ -1297,8 +1296,7 @@ TclLindexFlat(
Tcl_IncrRefCount(listPtr);
for (i=0 ; i<indexCount && listPtr ; i++) {
- size_t index;
- size_t listLen = 0;
+ size_t index, listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
@@ -1391,7 +1389,7 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- ListGetIntRep(indexArgPtr, listRepPtr);
+ ListGetInternalRep(indexArgPtr, listRepPtr);
if (listRepPtr == NULL
&& TclGetIntForIndexM(NULL, indexArgPtr, (size_t)WIDE_MAX - 1, &index) == TCL_OK) {
/*
@@ -1651,7 +1649,7 @@ TclLsetFlat(
listRepPtr->refCount++;
TclFreeInternalRep(objPtr);
- ListSetIntRep(objPtr, listRepPtr);
+ ListSetInternalRep(objPtr, listRepPtr);
listRepPtr->refCount--;
TclInvalidateStringRep(objPtr);
@@ -1756,7 +1754,7 @@ TclListObjSetElement(
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result;
size_t length;
@@ -1775,7 +1773,7 @@ TclListObjSetElement(
if (result != TCL_OK) {
return result;
}
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
}
elemCount = listRepPtr->elemCount;
@@ -1799,7 +1797,7 @@ TclListObjSetElement(
*/
if (listRepPtr->refCount > 1) {
- Tcl_Obj **dst, **src = &listRepPtr->elements;
+ Tcl_Obj **dst, **src = listRepPtr->elements;
List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);
if (newPtr == NULL) {
@@ -1812,7 +1810,7 @@ TclListObjSetElement(
newPtr->elemCount = elemCount;
newPtr->canonicalFlag = listRepPtr->canonicalFlag;
- dst = &newPtr->elements;
+ dst = newPtr->elements;
while (elemCount--) {
*dst = *src++;
Tcl_IncrRefCount(*dst++);
@@ -1821,9 +1819,9 @@ TclListObjSetElement(
listRepPtr->refCount--;
listRepPtr = newPtr;
- ListResetIntRep(listPtr, listRepPtr);
+ ListResetInternalRep(listPtr, listRepPtr);
}
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
/*
* Add a reference to the new list element.
@@ -1847,10 +1845,10 @@ TclListObjSetElement(
* Invalidate outdated internalreps.
*/
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount++;
TclFreeInternalRep(listPtr);
- ListSetIntRep(listPtr, listRepPtr);
+ ListSetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount--;
TclInvalidateStringRep(listPtr);
@@ -1880,11 +1878,11 @@ FreeListInternalRep(
{
List *listRepPtr;
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
assert(listRepPtr != NULL);
if (listRepPtr->refCount-- <= 1) {
- Tcl_Obj **elemPtrs = &listRepPtr->elements;
+ Tcl_Obj **elemPtrs = listRepPtr->elements;
int i, numElems = listRepPtr->elemCount;
for (i = 0; i < numElems; i++) {
@@ -1916,9 +1914,9 @@ DupListInternalRep(
{
List *listRepPtr;
- ListGetIntRep(srcPtr, listRepPtr);
+ ListGetInternalRep(srcPtr, listRepPtr);
assert(listRepPtr != NULL);
- ListSetIntRep(copyPtr, listRepPtr);
+ ListSetInternalRep(copyPtr, listRepPtr);
}
/*
@@ -1986,7 +1984,7 @@ SetListFromAny(
* Populate the list representation.
*/
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
while (!done) {
*elemPtrs++ = keyPtr;
@@ -1996,8 +1994,7 @@ SetListFromAny(
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
- size_t estCount;
- size_t length;
+ size_t estCount, length;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
/*
@@ -2012,7 +2009,7 @@ SetListFromAny(
if (listRepPtr == NULL) {
return TCL_ERROR;
}
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
/*
* Each iteration, parse and store a list element.
@@ -2027,7 +2024,7 @@ SetListFromAny(
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
fail:
- while (--elemPtrs >= &listRepPtr->elements) {
+ while (--elemPtrs >= listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
Tcl_Free(listRepPtr);
@@ -2057,7 +2054,7 @@ SetListFromAny(
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
- listRepPtr->elemCount = elemPtrs - &listRepPtr->elements;
+ listRepPtr->elemCount = elemPtrs - listRepPtr->elements;
}
/*
@@ -2066,7 +2063,7 @@ SetListFromAny(
* Tcl_GetStringFromObj, to use the old internalRep.
*/
- ListSetIntRep(objPtr, listRepPtr);
+ ListSetInternalRep(objPtr, listRepPtr);
return TCL_OK;
}
@@ -2095,14 +2092,13 @@ UpdateStringOfList(
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- size_t numElems, i;
- size_t length, bytesNeeded = 0;
+ size_t numElems, i, length, bytesNeeded = 0;
const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
List *listRepPtr;
- ListGetIntRep(listPtr, listRepPtr);
+ ListGetInternalRep(listPtr, listRepPtr);
assert(listRepPtr != NULL);
@@ -2138,7 +2134,7 @@ UpdateStringOfList(
flagPtr = (char *)Tcl_Alloc(numElems);
}
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = Tcl_GetStringFromObj(elemPtrs[i], &length);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index e8f379d..7029b3f 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1536,12 +1536,15 @@ TclPushProcCallFrame(
* is up-to-date), the namespace must match (so variable handling
* is right) and the resolverEpoch must match (so that new shadowed
* commands and/or resolver changes are considered).
+ * Ensure the ByteCode's procPtr is the same (or it's precompiled).
*/
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
- || (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
+ || (codePtr->nsEpoch != nsPtr->resolverEpoch)
+ || ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes)
+ ) {
goto doCompilation;
}
} else {
@@ -1882,6 +1885,7 @@ TclProcCompileProc(
* procPtr->numCompiledLocals if new local variables are found while
* compiling.
*
+ * Ensure the ByteCode's procPtr is the same (or it is pure precompiled).
* Precompiled procedure bodies, however, are immutable and therefore they
* are not recompiled, even if things have changed.
*/
@@ -1890,7 +1894,9 @@ TclProcCompileProc(
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == nsPtr)
- && (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
+ && (codePtr->nsEpoch == nsPtr->resolverEpoch)
+ && ((codePtr->procPtr == procPtr) || !bodyPtr->bytes)
+ ) {
return TCL_OK;
}
@@ -2106,6 +2112,13 @@ TclProcCleanupProc(
Interp *iPtr = procPtr->iPtr;
if (bodyPtr != NULL) {
+ /* procPtr is stored in body's ByteCode, so ensure to reset it. */
+ ByteCode *codePtr;
+
+ ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
+ if (codePtr != NULL && codePtr->procPtr == procPtr) {
+ codePtr->procPtr = NULL;
+ }
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 9cd3811..a816062 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -49,44 +49,43 @@
* file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms
* and ix86-isms are factored out here.
*/
-
-#if defined(__GNUC__)
+# if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
-#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
-#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
-# define FPU_IEEE_ROUNDING 0x027F
-# define ADJUST_FPU_CONTROL_WORD
-#define TCL_IEEE_DOUBLE_ROUNDING \
+# define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
+# define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
+# define FPU_IEEE_ROUNDING 0x027F
+# define ADJUST_FPU_CONTROL_WORD
+# define TCL_IEEE_DOUBLE_ROUNDING_DECL \
fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \
- fpu_control_t oldRoundingMode; \
+ fpu_control_t oldRoundingMode;
+# define TCL_IEEE_DOUBLE_ROUNDING \
_FPU_GETCW(oldRoundingMode); \
_FPU_SETCW(roundTo53Bits)
-#define TCL_DEFAULT_DOUBLE_ROUNDING \
+# define TCL_DEFAULT_DOUBLE_ROUNDING \
_FPU_SETCW(oldRoundingMode)
/*
* Sun ProC needs sunmath for rounding control on x86 like gcc above.
*/
-#elif defined(__sun)
-#include <sunmath.h>
-#define TCL_IEEE_DOUBLE_ROUNDING \
+# elif defined(__sun)
+# include <sunmath.h>
+# define TCL_IEEE_DOUBLE_ROUNDING_DECL
+# define TCL_IEEE_DOUBLE_ROUNDING \
ieee_flags("set","precision","double",NULL)
-#define TCL_DEFAULT_DOUBLE_ROUNDING \
+# define TCL_DEFAULT_DOUBLE_ROUNDING \
ieee_flags("clear","precision",NULL,NULL)
+# endif
+#endif
/*
* Other platforms are assumed to always operate in full IEEE mode, so we make
* the macros to go in and out of that mode do nothing.
*/
-
-#else /* !__GNUC__ && !__sun */
-#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0)
-#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0)
-#endif
-#else /* !__i386 */
-#define TCL_IEEE_DOUBLE_ROUNDING ((void) 0)
-#define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0)
+#ifndef TCL_IEEE_DOUBLE_ROUNDING /* !__i386 || (!__GNUC__ && !__sun) */
+# define TCL_IEEE_DOUBLE_ROUNDING_DECL
+# define TCL_IEEE_DOUBLE_ROUNDING ((void) 0)
+# define TCL_DEFAULT_DOUBLE_ROUNDING ((void) 0)
#endif
/*
@@ -1210,7 +1209,6 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
goto endgame;
-
}
p++;
len--;
@@ -1679,7 +1677,8 @@ MakeLowPrecisionDouble(
int numSigDigs, /* Number of digits in the significand */
long exponent) /* Power of ten */
{
- double retval; /* Value of the number. */
+ TCL_IEEE_DOUBLE_ROUNDING_DECL
+
mp_int significandBig; /* Significand expressed as a bignum. */
/*
@@ -1687,18 +1686,25 @@ MakeLowPrecisionDouble(
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
- * ulp, so we need to change rounding mode to 53-bits.
+ * ulp, so we need to change rounding mode to 53-bits. We also make
+ * 'retval' volatile, so that it doesn't get promoted to a register.
*/
-
- TCL_IEEE_DOUBLE_ROUNDING;
+ volatile double retval; /* Value of the number. */
/*
- * Test for the easy cases.
+ * Test for zero significand, which requires explicit construction
+ * of -0.0. (Unary minus returns a positive zero.)
*/
-
if (significand == 0) {
return copysign(0.0, -signum);
}
+
+ /*
+ * Set the FP control word for 53 bits, WARNING: It must be reset
+ * before returning.
+ */
+ TCL_IEEE_DOUBLE_ROUNDING;
+
if (numSigDigs <= QUICK_MAX) {
if (exponent >= 0) {
if (exponent <= mmaxpow) {
@@ -1798,7 +1804,8 @@ MakeHighPrecisionDouble(
int numSigDigs, /* Number of significant digits */
long exponent) /* Power of 10 by which to multiply */
{
- double retval;
+ TCL_IEEE_DOUBLE_ROUNDING_DECL
+
int machexp = 0; /* Machine exponent of a power of 10. */
/*
@@ -1806,19 +1813,30 @@ MakeHighPrecisionDouble(
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
- * ulp, so we need to change rounding mode to 53-bits.
+ * ulp, so we need to change rounding mode to 53-bits. We also make
+ * 'retval' volatile to make sure that it doesn't get promoted to a
+ * register.
*/
-
- TCL_IEEE_DOUBLE_ROUNDING;
+ volatile double retval;
/*
- * Quick checks for zero, and over/underflow. Be careful to avoid
- * integer overflow when calculating with 'exponent'.
+ * A zero significand requires explicit construction of -0.0.
+ * (Unary minus returns positive zero.)
*/
-
if (mp_iszero(significand)) {
return copysign(0.0, -signum);
}
+
+ /*
+ * Set the 53-bit rounding mode. WARNING: It must be reset before
+ * returning.
+ */
+ TCL_IEEE_DOUBLE_ROUNDING;
+
+ /*
+ * Make quick checks for over/underflow. Be careful to avoid
+ * integer overflow when calculating with 'exponent'.
+ */
if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) {
retval = HUGE_VAL;
goto returnValue;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 3877369..ac0c210 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -335,6 +335,7 @@ static Tcl_ObjCmdProc TestInterpResolverCmd;
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
static Tcl_ObjCmdProc TestcpuidCmd;
#endif
+static Tcl_ObjCmdProc TestApplyLambdaObjCmd;
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -709,6 +710,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
+ NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -8081,7 +8084,85 @@ TestInterpResolverCmd(
}
return TCL_OK;
}
-
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TestApplyLambdaObjCmd --
+ *
+ * Implements the Tcl command testapplylambda. This tests the apply
+ * implementation handling of a lambda where the lambda has a list
+ * internal representation where the second element's internal
+ * representation is already a byte code object.
+ *
+ * Results:
+ * TCL_OK - Success. Caller should check result is 42
+ * TCL_ERROR - Error.
+ *
+ * Side effects:
+ * In the presence of the apply bug, may panic. Otherwise
+ * Interpreter result holds result or error message.
+ *
+ *------------------------------------------------------------------------
+ */
+int TestApplyLambdaObjCmd (
+ TCL_UNUSED(void*),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int), /* objc. */
+ TCL_UNUSED(Tcl_Obj *const *)) /* objv. */
+{
+ Tcl_Obj *lambdaObjs[2];
+ Tcl_Obj *evalObjs[2];
+ Tcl_Obj *lambdaObj;
+ int result;
+
+ /* Create a lambda {{} {set a 42}} */
+ lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
+ lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */
+ lambdaObj = Tcl_NewListObj(2, lambdaObjs);
+ Tcl_IncrRefCount(lambdaObj);
+
+ /* Create the command "apply {{} {set a 42}" */
+ evalObjs[0] = Tcl_NewStringObj("apply", -1);
+ Tcl_IncrRefCount(evalObjs[0]);
+ /*
+ * NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
+ * it will get shimmered to a Lambda internal representation but we
+ * want to hold on to our list representation.
+ */
+ evalObjs[1] = Tcl_DuplicateObj(lambdaObj);
+ Tcl_IncrRefCount(evalObjs[1]);
+
+ /* Evaluate it */
+ result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(evalObjs[0]);
+ Tcl_DecrRefCount(evalObjs[1]);
+ return result;
+ }
+ /*
+ * So far so good. At this point,
+ * - evalObjs[1] has an internal representation of Lambda
+ * - lambdaObj[1] ({set a 42}) has been shimmered to
+ * an internal representation of ByteCode.
+ */
+ Tcl_DecrRefCount(evalObjs[1]); /* Don't need this anymore */
+ /*
+ * The bug trigger. Repeating the command but:
+ * - we are calling apply with a lambda that is a list (as BEFORE),
+ * BUT
+ * - The body of the lambda (lambdaObjs[1]) ALREADY has internal
+ * representation of ByteCode and thus will not be compiled again
+ */
+ evalObjs[1] = lambdaObj; /* lambdaObj already has a ref count so
+ no need for IncrRef */
+ result = Tcl_EvalObjv(interp, 2, evalObjs, TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(evalObjs[0]);
+ Tcl_DecrRefCount(lambdaObj);
+
+ return result;
+}
+
/*
* Local Variables:
* mode: c
@@ -8091,3 +8172,4 @@ TestInterpResolverCmd(
* indent-tabs-mode: nil
* End:
*/
+
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 532abab..e882f18 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -508,8 +508,7 @@ Tcl_UtfToUniChar(
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
- }
- else if (byte < 0xF5) {
+ } else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
@@ -604,8 +603,7 @@ Tcl_UtfToChar16(
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
- }
- else if (byte < 0xF5) {
+ } else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by at least two trail bytes.
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index 103fd05..f02f912 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -410,7 +410,7 @@ static const Tcl_Filesystem zipfsFilesystem = {
static Tcl_ChannelType ZipChannelType = {
"zip", /* Type name. */
TCL_CHANNEL_VERSION_5,
- TCL_CLOSE2PROC, /* Close channel, clean instance data */
+ NULL, /* Close channel, clean instance data */
ZipChannelRead, /* Handle read request */
ZipChannelWrite, /* Handle write request */
NULL, /* Move location of access point, NULL'able */
generated by cgit v0.12 at 2025-12-09 22:14:56 (GMT)