summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2022-08-21 21:43:16 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2022-08-21 21:43:16 (GMT)
commitc42f34e33320fc95bf80bdca0da2bae7bebbbe0f (patch)
treee045a34d312e2e08725507f0d2e43c6d65bc400a /generic
parent64a63fa7c5594097d782968787ad37e46f9e4f5e (diff)
parent916d72ec1ce61ebd585a78c6a9565f5c49bb8d24 (diff)
downloadtcl-c42f34e33320fc95bf80bdca0da2bae7bebbbe0f.zip
tcl-c42f34e33320fc95bf80bdca0da2bae7bebbbe0f.tar.gz
tcl-c42f34e33320fc95bf80bdca0da2bae7bebbbe0f.tar.bz2
Merge 8.7
Diffstat (limited to 'generic')
-rw-r--r--generic/regexec.c66
-rw-r--r--generic/tcl.decls4
-rw-r--r--generic/tcl.h11
-rw-r--r--generic/tclBasic.c45
-rw-r--r--generic/tclBinary.c22
-rw-r--r--generic/tclClock.c4
-rw-r--r--generic/tclCmdIL.c6
-rw-r--r--generic/tclDecls.h8
-rw-r--r--generic/tclEnsemble.c332
-rw-r--r--generic/tclExecute.c37
-rw-r--r--generic/tclIO.c9
-rw-r--r--generic/tclInt.h12
-rw-r--r--generic/tclInterp.c2
-rw-r--r--generic/tclLink.c26
-rw-r--r--generic/tclListObj.c647
-rw-r--r--generic/tclNotify.c38
-rw-r--r--generic/tclOO.c16
-rw-r--r--generic/tclOO.decls14
-rw-r--r--generic/tclOO.h29
-rw-r--r--generic/tclOOCall.c6
-rw-r--r--generic/tclOODecls.h23
-rw-r--r--generic/tclOODefineCmds.c6
-rw-r--r--generic/tclOOInt.h21
-rw-r--r--generic/tclOOMethod.c140
-rw-r--r--generic/tclOOStubInit.c3
-rw-r--r--generic/tclProc.c17
-rw-r--r--generic/tclStrToD.c88
-rw-r--r--generic/tclStringObj.c39
-rw-r--r--generic/tclStubInit.c1
-rw-r--r--generic/tclTest.c127
-rw-r--r--generic/tclUtf.c6
31 files changed, 1083 insertions, 722 deletions
diff --git a/generic/regexec.c b/generic/regexec.c
index 54cb905..7ef048e 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -236,13 +236,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;
}
@@ -279,11 +281,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;
}
@@ -299,8 +303,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];
}
@@ -640,10 +645,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);
@@ -651,10 +657,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);
@@ -920,17 +927,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;
}
@@ -1007,8 +1017,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;
}
@@ -1022,8 +1033,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 *));
@@ -1066,8 +1078,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 */
@@ -1093,8 +1106,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));
@@ -1105,8 +1119,9 @@ citerdissect(struct vars * v,
nverified = i;
continue;
}
- if (er == REG_NOMATCH)
+ if (er == REG_NOMATCH) {
break;
+ }
/* oops, something failed */
FREE(endpts);
return er;
@@ -1180,8 +1195,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;
}
@@ -1235,8 +1251,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,
@@ -1250,8 +1267,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 */
@@ -1272,8 +1290,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));
@@ -1284,8 +1303,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/tcl.decls b/generic/tcl.decls
index fc3c8cb..d08ba0a 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -734,7 +734,7 @@ declare 204 {
const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
- void Tcl_QueueEvent(Tcl_Event *evPtr, int flags)
+ void Tcl_QueueEvent(Tcl_Event *evPtr, int position)
}
declare 206 {
int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
@@ -1144,7 +1144,7 @@ declare 318 {
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
- int flags)
+ int position)
}
declare 320 {
int Tcl_UniCharAtIndex(const char *src, int index)
diff --git a/generic/tcl.h b/generic/tcl.h
index 94196a2..101ae0b 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -926,13 +926,8 @@ typedef struct Tcl_CmdInfo {
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
-#if (TCL_MAJOR_VERSION > 8) || defined(TCL_NO_DEPRECATED)
- Tcl_ObjCmdProc2 *objProc2; /* Command's object-based function. */
- void *objClientData2; /* ClientData for object proc. */
-#else
- void *reserved1;
- void *reserved2;
-#endif
+ Tcl_ObjCmdProc2 *objProc2; /* Not used in Tcl 8.7. */
+ void *objClientData2; /* Not used in Tcl 8.7. */
} Tcl_CmdInfo;
/*
@@ -2391,7 +2386,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
#if defined(_WIN32)
TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
#else
-# define Tcl_ConsolePanic ((Tcl_PanicProc *)0)
+# define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL)
#endif
#ifdef USE_TCL_STUBS
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d0af547..f7f6ed8 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1350,11 +1350,11 @@ TclRegisterCommandTypeName(
int isNew;
hPtr = Tcl_CreateHashEntry(&commandTypeTable,
- (void *) implementationProc, &isNew);
+ implementationProc, &isNew);
Tcl_SetHashValue(hPtr, (void *) nameStr);
} else {
hPtr = Tcl_FindHashEntry(&commandTypeTable,
- (void *) implementationProc);
+ implementationProc);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -1865,7 +1865,7 @@ DeleteInterpProc(
*/
Tcl_MutexLock(&cancelLock);
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
+ hPtr = Tcl_FindHashEntry(&cancelTable, iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
@@ -3473,17 +3473,6 @@ Tcl_GetCommandInfoFromToken(
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
-#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
- if (infoPtr->objProc == cmdWrapperProc) {
- CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->objClientData;
- infoPtr->objProc2 = info->proc;
- infoPtr->objClientData2 = info->clientData;
- infoPtr->isNativeObjectProc = 2;
- } else {
- infoPtr->objProc2 = cmdWrapper2Proc;
- infoPtr->objClientData2 = cmdPtr;
- }
-#endif
return 1;
}
@@ -4664,7 +4653,7 @@ Tcl_CancelEval(
goto done;
}
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
+ hPtr = Tcl_FindHashEntry(&cancelTable, interp);
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
@@ -5354,8 +5343,8 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
- int length, traceCode = TCL_OK;
+ int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ int traceCode = TCL_OK;
const char *command = TclGetStringFromObj(commandPtr, &length);
/*
@@ -5625,7 +5614,7 @@ TclEvalEx(
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
- unsigned int 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
@@ -5797,7 +5786,7 @@ TclEvalEx(
wordStart = tokenPtr->start;
lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL)
- ? wordLine : TCL_INDEX_NONE;
+ ? wordLine : -1;
if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
@@ -6230,7 +6219,7 @@ TclArgumentRelease(
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
+ Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]);
if (!hPtr) {
continue;
@@ -6282,7 +6271,7 @@ TclArgumentBCEnter(
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
@@ -6388,7 +6377,7 @@ TclArgumentBCRelease(
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
+ Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
@@ -6453,7 +6442,7 @@ TclArgumentGet(
* stack. That is nearest.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
@@ -6467,7 +6456,7 @@ TclArgumentGet(
* that stack.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
@@ -6510,7 +6499,7 @@ Tcl_Eval(
* previous call to Tcl_CreateInterp). */
const char *script) /* Pointer to TCL command to execute. */
{
- int code = Tcl_EvalEx(interp, script, -1, 0);
+ int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0);
/*
* For backwards compatibility with old C code that predates the object
@@ -7359,10 +7348,11 @@ Tcl_AppendObjToErrorInfo(
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
- const char *message = TclGetString(objPtr);
+ int length;
+ const char *message = TclGetStringFromObj(objPtr, &length);
Tcl_IncrRefCount(objPtr);
- Tcl_AddObjErrorInfo(interp, message, objPtr->length);
+ Tcl_AddObjErrorInfo(interp, message, length);
Tcl_DecrRefCount(objPtr);
}
@@ -7534,6 +7524,7 @@ Tcl_VarEvalVA(
*
*----------------------------------------------------------------------
*/
+
int
Tcl_VarEval(
Tcl_Interp *interp,
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index bf40924..8b974c1 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -649,7 +649,7 @@ SetByteArrayFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- size_t length, bad;
+ int length, bad;
const char *src, *srcEnd;
unsigned char *dst;
Tcl_UniChar ch = 0;
@@ -663,8 +663,8 @@ SetByteArrayFromAny(
return TCL_OK;
}
- src = TclGetString(objPtr);
- length = bad = objPtr->length;
+ src = TclGetStringFromObj(objPtr, &length);
+ bad = length;
srcEnd = src + length;
/* Note the allocation is over-sized, possibly by a factor of four,
@@ -1001,7 +1001,7 @@ TclInitBinaryCmd(
static int
BinaryFormatCmd(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1506,7 +1506,7 @@ BinaryFormatCmd(
static int
BinaryScanCmd(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2583,7 +2583,7 @@ DeleteScanNumberCache(
static int
BinaryEncodeHex(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2627,7 +2627,7 @@ BinaryEncodeHex(
static int
BinaryDecodeHex(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2751,7 +2751,7 @@ BinaryDecodeHex(
static int
BinaryEncode64(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -2873,7 +2873,7 @@ BinaryEncode64(
static int
BinaryEncodeUu(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3022,7 +3022,7 @@ BinaryEncodeUu(
static int
BinaryDecodeUu(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -3195,7 +3195,7 @@ BinaryDecodeUu(
static int
BinaryDecode64(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 0669ffe..86eed73 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 f32fd98..1197b92 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2901,7 +2901,7 @@ Tcl_LrepeatObjCmd(
List *listRepPtr = ListRepPtr(listPtr);
listRepPtr->elemCount = elementCount*objc;
- dataArray = &listRepPtr->elements;
+ dataArray = listRepPtr->elements;
}
/*
@@ -3088,7 +3088,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];
@@ -4414,7 +4414,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/tclDecls.h b/generic/tclDecls.h
index 58eb1d0..3917d0f 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -642,7 +642,7 @@ EXTERN int Tcl_PutEnv(const char *assignment);
/* 204 */
EXTERN const char * Tcl_PosixError(Tcl_Interp *interp);
/* 205 */
-EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int flags);
+EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position);
/* 206 */
EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead);
/* 207 */
@@ -980,7 +980,7 @@ EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
/* 319 */
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
- Tcl_Event *evPtr, int flags);
+ Tcl_Event *evPtr, int position);
/* 320 */
EXTERN int Tcl_UniCharAtIndex(const char *src, int index);
/* 321 */
@@ -2236,7 +2236,7 @@ typedef struct TclStubs {
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
int (*tcl_PutEnv) (const char *assignment); /* 203 */
const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
- void (*tcl_QueueEvent) (Tcl_Event *evPtr, int flags); /* 205 */
+ void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 205 */
int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */
@@ -2350,7 +2350,7 @@ typedef struct TclStubs {
int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
- void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int flags); /* 319 */
+ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 319 */
int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
int (*tcl_UniCharToLower) (int ch); /* 321 */
int (*tcl_UniCharToTitle) (int ch); /* 322 */
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 5c30a0b..7a295ba 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);
@@ -70,8 +70,8 @@ enum EnsConfigOpts {
};
/*
- * This structure defines a Tcl object type that contains a reference to an
- * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
+ * ensembleCmdType is a Tcl object type that contains a reference to an
+ * ensemble subcommand, e.g. the "length" in [string length ab]. It is used
* to cache the mapping between the subcommand itself and the real command
* that implements it.
*/
@@ -151,7 +151,7 @@ NewNsObj(
int
TclNamespaceEnsembleCmd(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -163,7 +163,8 @@ TclNamespaceEnsembleCmd(
Tcl_DictSearch search;
Tcl_Obj *listObj;
const char *simpleName;
- int index, done;
+ int index;
+ int done;
if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
if (!Tcl_InterpDeleted(interp)) {
@@ -187,7 +188,8 @@ TclNamespaceEnsembleCmd(
switch ((enum EnsSubcmds) index) {
case ENS_CREATE: {
const char *name;
- int len, allocatedMapFlag = 0;
+ int len;
+ int allocatedMapFlag = 0;
/*
* Defaults
*/
@@ -498,7 +500,8 @@ TclNamespaceEnsembleCmd(
Tcl_SetObjResult(interp, resultObj);
} else {
- int len, allocatedMapFlag = 0;
+ int len;
+ int allocatedMapFlag = 0;
Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
*unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
int permitPrefix, flags = 0; /* silence gcc 4 warning */
@@ -940,7 +943,8 @@ Tcl_SetEnsembleMappingDict(
return TCL_ERROR;
}
if (mapDict != NULL) {
- int size, done;
+ int size;
+ int done;
Tcl_DictSearch search;
Tcl_Obj *valuePtr;
@@ -1523,7 +1527,8 @@ TclMakeEnsemble(
Tcl_DString buf, hiddenBuf;
const char **nameParts = NULL;
const char *cmdName = NULL;
- int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
+ int i, nameCount = 0;
+ int ensembleFlags = 0, hiddenLen;
/*
* Construct the path for the ensemble namespace and create it.
@@ -1674,7 +1679,7 @@ TclMakeEnsemble(
int
TclEnsembleImplementationCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1685,7 +1690,7 @@ TclEnsembleImplementationCmd(
static int
NsEnsembleImplementationCmdNR(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -1704,7 +1709,7 @@ NsEnsembleImplementationCmdNR(
int subIdx;
/*
- * Must recheck objc, since numParameters might have changed. Cf. test
+ * Must recheck objc since numParameters might have changed. See test
* namespace-53.9.
*/
@@ -1712,7 +1717,7 @@ NsEnsembleImplementationCmdNR(
subIdx = 1 + ensemblePtr->numParameters;
if (objc < subIdx + 1) {
/*
- * We don't have a subcommand argument. Make error message.
+ * No subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
@@ -1744,18 +1749,16 @@ NsEnsembleImplementationCmdNR(
}
/*
- * Determine if the table of subcommands is right. If so, we can just look
- * up in there and go straight to dispatch.
+ * If the table of subcommands is valid just lookup up the command there
+ * and go to dispatch.
*/
subObj = objv[subIdx];
if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
/*
- * Table of subcommands is still valid; therefore there might be a
- * valid cache of discovered information which we can reuse. Do the
- * check here, and if we're still valid, we can jump straight to the
- * part where we do the invocation of the subcommand.
+ * Table of subcommands is still valid so if the internal representtion
+ * is an ensembleCmd, just call it.
*/
EnsembleCmdRep *ensembleCmd;
@@ -1777,8 +1780,8 @@ NsEnsembleImplementationCmdNR(
}
/*
- * Look in the hashtable for the subcommand name; this is the fastest way
- * of all if there is no cache in operation.
+ * Look in the hashtable for the named subcommand. This is the fastest
+ * path if there is no cache in operation.
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
@@ -1786,26 +1789,25 @@ NsEnsembleImplementationCmdNR(
if (hPtr != NULL) {
/*
- * Cache for later in the subcommand object.
+ * Cache ensemble in the subcommand object for later.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
- * Could not map, no prefixing, go to unknown/error handling.
+ * Could not map. No prefixing. Go to unknown/error handling.
*/
goto unknownOrAmbiguousSubcommand;
} else {
/*
- * If we've not already confirmed the command with the hash as part of
- * building our export table, we need to scan the sorted array for
- * matches.
+ * If the command isn't yet confirmed with the hash as part of building
+ * the export table, scan the sorted array for matches.
*/
- const char *subcmdName; /* Name of the subcommand, or unique prefix of
- * it (will be an error for a non-unique
- * prefix). */
+ const char *subcmdName; /* Name of the subcommand or unique prefix of
+ * it (a non-unique prefix produces an error).
+ */
char *fullName = NULL; /* Full name of the subcommand. */
int stringLength, i;
int tableLength = ensemblePtr->subcommandTable.numEntries;
@@ -1820,10 +1822,10 @@ NsEnsembleImplementationCmdNR(
if (cmp == 0) {
if (fullName != NULL) {
/*
- * Since there's never the exact-match case to worry about
- * (hash search filters this), getting here indicates that
- * our subcommand is an ambiguous prefix of (at least) two
- * exported subcommands, which is an error case.
+ * Hash search filters out the exact-match case, so getting
+ * here indicates that the subcommand is an ambiguous
+ * prefix of at least two exported subcommands, which is an
+ * error case.
*/
goto unknownOrAmbiguousSubcommand;
@@ -1831,9 +1833,8 @@ NsEnsembleImplementationCmdNR(
fullName = ensemblePtr->subcommandArrayPtr[i];
} else if (cmp < 0) {
/*
- * Because we are searching a sorted table, we can now stop
- * searching because we have gone past anything that could
- * possibly match.
+ * The table is sorted so stop searching because a match would
+ * have been found already.
*/
break;
@@ -1841,7 +1842,7 @@ NsEnsembleImplementationCmdNR(
}
if (fullName == NULL) {
/*
- * The subcommand is not a prefix of anything, so bail out!
+ * The subcommand is not a prefix of anything. Bail out!
*/
goto unknownOrAmbiguousSubcommand;
@@ -1871,21 +1872,19 @@ NsEnsembleImplementationCmdNR(
runResultingSubcommand:
/*
- * Do the real work of execution of the subcommand by building an array of
- * objects (note that this is potentially not the same length as the
- * number of arguments to this ensemble command), populating it and then
- * feeding it back through the main command-lookup engine. In theory, we
- * could look up the command in the namespace ourselves, as we already
- * have the namespace in which it is guaranteed to exist,
+ * Execute the subcommand by populating an array of objects, which might
+ * not be the same length as the number of arguments to this ensemble
+ * command, and then handing it to the main command-lookup engine. In
+ * theory, the command could be looked up right here using the namespace in
+ * which it is guaranteed to exist,
*
* ((Q: That's not true if the -map option is used, is it?))
*
- * but we don't do that (the cacheing of the command object used should
- * help with that.)
+ * but don't do that because cacheing of the command object should help.
*/
{
- Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
+ Tcl_Obj *copyPtr; /* The list of words to dispatch on.
* Will be freed by the dispatch engine. */
Tcl_Obj **copyObjv;
int copyObjc, prefixObjc;
@@ -1908,8 +1907,8 @@ NsEnsembleImplementationCmdNR(
TclDecrRefCount(prefixObj);
/*
- * Record what arguments the script sent in so that things like
- * Tcl_WrongNumArgs can give the correct error message. Parameters
+ * Record the words of the command as given so that routines like
+ * Tcl_WrongNumArgs can produce the correct error message. Parameters
* count both as inserted and removed arguments.
*/
@@ -1931,10 +1930,9 @@ NsEnsembleImplementationCmdNR(
unknownOrAmbiguousSubcommand:
/*
- * Have not been able to match the subcommand asked for with a real
- * subcommand that we export. See whether a handler has been registered
- * for dealing with this situation. Will only call (at most) once for any
- * particular ensemble invocation.
+ * The named subcommand did not match any exported command. If there is a
+ * handler registered unknown subcommands, call it, but not more than once
+ * for this call.
*/
if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
@@ -1950,10 +1948,10 @@ NsEnsembleImplementationCmdNR(
}
/*
- * We cannot determine what subcommand to hand off to, so generate a
- * (standard) failure message. Note the one odd case compared with
- * standard ensemble-like command, which is where a namespace has no
- * exported commands at all...
+ * Could not find a routine for the named subcommand so generate a standard
+ * failure message. The one odd case compared with a standard
+ * ensemble-like command is where a namespace has no exported commands at
+ * all...
*/
Tcl_ResetResult(interp);
@@ -1987,7 +1985,7 @@ NsEnsembleImplementationCmdNR(
int
TclClearRootEnsemble(
- TCL_UNUSED(ClientData *),
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -2000,8 +1998,8 @@ TclClearRootEnsemble(
*
* TclInitRewriteEnsemble --
*
- * Applies a rewrite of arguments so that an ensemble subcommand will
- * report error messages correctly for the overall command.
+ * Applies a rewrite of arguments so that an ensemble subcommand
+ * correctly reports any error messages for the overall command.
*
* Results:
* Whether this is the first rewrite applied, a value which must be
@@ -2079,7 +2077,7 @@ TclResetRewriteEnsemble(
*
* TclSpellFix --
*
- * Record a spelling correction that needs making in the generation of
+ * Records a spelling correction that needs making in the generation of
* the WrongNumArgs usage message.
*
* Results:
@@ -2093,7 +2091,7 @@ TclResetRewriteEnsemble(
static int
FreeER(
- ClientData data[],
+ void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
@@ -2144,8 +2142,8 @@ TclSpellFix(
if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
/*
- * Misspelled value was inserted. We cannot directly jump to the bad
- * value, but have to search.
+ * Misspelled value was inserted. Cannot directly jump to the bad
+ * value. Must search.
*/
idx = 1;
@@ -2257,22 +2255,22 @@ TclFetchEnsembleRoot(
/*
* ----------------------------------------------------------------------
*
- * EnsmebleUnknownCallback --
+ * EnsembleUnknownCallback --
*
- * Helper for the ensemble engine that handles the procesing of unknown
- * callbacks. See the user documentation of the ensemble unknown handler
- * for details; this function is only ever called when such a function is
- * defined, and is only ever called once per ensemble dispatch (i.e. if a
- * reparse still fails, this isn't called again).
+ * Helper for the ensemble engine. Calls the routine registered for
+ * "ensemble unknown" case. See the user documentation of the
+ * ensemble unknown handler for details. Only called when such a
+ * function is defined, and is only called once per ensemble dispatch.
+ * I.e. even if a reparse still fails, this isn't called again.
*
* Results:
* TCL_OK - *prefixObjPtr contains the command words to dispatch
* to.
- * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid).
- * TCL_ERROR - Something went wrong! Error message in interpreter.
+ * TCL_CONTINUE - Need to reparse, i.e. *prefixObjPtr is invalid
+ * TCL_ERROR - Something went wrong. Error message in interpreter.
*
* Side effects:
- * Calls the Tcl interpreter, so arbitrary.
+ * Arbitrary, due to evaluation of script provided by client.
*
* ----------------------------------------------------------------------
*/
@@ -2285,28 +2283,28 @@ EnsembleUnknownCallback(
Tcl_Obj *const objv[],
Tcl_Obj **prefixObjPtr)
{
- int paramc, i, result, prefixObjc;
+ int paramc, i, prefixObjc;
+ int result;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
- * Create the unknown command callback to determine what to do.
+ * Create the "unknown" command callback to determine what to do.
*/
unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
- for (i=1 ; i<objc ; i++) {
+ for (i = 1 ; i < objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
TclListObjGetElementsM(NULL, unknownCmd, &paramc, &paramv);
Tcl_IncrRefCount(unknownCmd);
/*
- * Now call the unknown handler. (We don't bother NRE-enabling this; deep
- * recursing through unknown handlers is horribly perverse.) Note that it
- * is always an error for an unknown handler to delete its ensemble; don't
- * do that!
+ * Call the "unknown" handler. No attempt to NRE-enable this as deep
+ * recursion through unknown handlers is perverse. It is always an error
+ * for an unknown handler to delete its ensemble. Don't do that.
*/
Tcl_Preserve(ensemblePtr);
@@ -2324,10 +2322,9 @@ EnsembleUnknownCallback(
Tcl_Release(ensemblePtr);
/*
- * If we succeeded, we should either have a list of words that form the
- * command to be executed, or an empty list. In the empty-list case, the
- * ensemble is believed to be updated so we should ask the ensemble engine
- * to reparse the original command.
+ * On success the result is a list of words that form the command to be
+ * executed. If the list is empty, the ensemble should have been updated,
+ * so ask the ensemble engine to reparse the original command.
*/
if (result == TCL_OK) {
@@ -2336,11 +2333,7 @@ EnsembleUnknownCallback(
TclDecrRefCount(unknownCmd);
Tcl_ResetResult(interp);
- /*
- * Namespace is still there. Check if the result is a valid list. If
- * it is, and it is non-empty, that list is what we are using as our
- * replacement.
- */
+ /* A non-empty list is the replacement command. */
if (TclListObjLengthM(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
TclDecrRefCount(*prefixObjPtr);
@@ -2353,7 +2346,7 @@ EnsembleUnknownCallback(
}
/*
- * Namespace alive & empty result => reparse.
+ * Empty result => reparse.
*/
TclDecrRefCount(*prefixObjPtr);
@@ -2361,7 +2354,7 @@ EnsembleUnknownCallback(
}
/*
- * Oh no! An exceptional result. Convert to an error.
+ * Convert exceptional result to an error.
*/
if (!Tcl_InterpDeleted(interp)) {
@@ -2401,16 +2394,16 @@ EnsembleUnknownCallback(
*
* MakeCachedEnsembleCommand --
*
- * Cache what we've computed so far; it's not nice to repeatedly copy
- * strings about. Note that to do this, we start by deleting any old
- * representation that there was (though if it was an out of date
- * ensemble rep, we can skip some of the deallocation process.)
+ * Caches what has been computed so far to minimize string copying.
+ * Starts by deleting any existing representation but reusing the existing
+ * structure if it is an ensembleCmd.
*
* Results:
- * None
+ * None.
*
* Side effects:
- * Alters the internal representation of the first object parameter.
+ * Converts the internal representation of the given object to an
+ * ensembleCmd.
*
*----------------------------------------------------------------------
*/
@@ -2432,8 +2425,7 @@ MakeCachedEnsembleCommand(
}
} else {
/*
- * Kill the old internal rep, and replace it with a brand new one of
- * our own.
+ * Replace any old internal representation with a new one.
*/
ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
@@ -2459,17 +2451,16 @@ MakeCachedEnsembleCommand(
*
* DeleteEnsembleConfig --
*
- * Destroys the data structure used to represent an ensemble. This is
- * called when the ensemble's command is deleted (which happens
- * automatically if the ensemble's namespace is deleted.) Maintainers
- * should note that ensembles should be deleted by deleting their
- * commands.
+ * Destroys the data structure used to represent an ensemble. Called when
+ * the procedure for the ensemble is deleted, which happens automatically
+ * if the namespace for the ensemble is deleted. Deleting the procedure
+ * for an ensemble is the right way to initiate cleanup.
*
* Results:
* None.
*
* Side effects:
- * Memory is (eventually) deallocated.
+ * Memory is eventually deallocated.
*
*----------------------------------------------------------------------
*/
@@ -2496,15 +2487,12 @@ ClearTable(
static void
DeleteEnsembleConfig(
- ClientData clientData)
+ void *clientData)
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
- /*
- * Unlink from the ensemble chain if it has not been marked as having been
- * done already.
- */
+ /* Unlink from the ensemble chain if it not already marked as unlinked. */
if (ensemblePtr->next != ensemblePtr) {
EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
@@ -2530,7 +2518,7 @@ DeleteEnsembleConfig(
ensemblePtr->flags |= ENSEMBLE_DEAD;
/*
- * Kill the pointer-containing fields.
+ * Release the fields that contain pointers.
*/
ClearTable(ensemblePtr);
@@ -2548,10 +2536,9 @@ DeleteEnsembleConfig(
}
/*
- * Arrange for the structure to be reclaimed. Note that this is complex
- * because we have to make sure that we can react sensibly when an
- * ensemble is deleted during the process of initialising the ensemble
- * (especially the unknown callback.)
+ * Arrange for the structure to be reclaimed. This is complex because it is
+ * necessary to react sensibly when an ensemble is deleted during its
+ * initialisation, particularly in the case of an unknown callback.
*/
Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
@@ -2562,11 +2549,11 @@ DeleteEnsembleConfig(
*
* BuildEnsembleConfig --
*
- * Create the internal data structures that describe how an ensemble
- * looks, being a hash mapping from the full command name to the Tcl list
- * that describes the implementation prefix words, and a sorted array of
- * all the full command names to allow for reasonably efficient
- * unambiguous prefix handling.
+ * Creates the internal data structures that describe how an ensemble
+ * looks. The structures are a hash map from the full command name to the
+ * Tcl list that describes the implementation prefix words, and a sorted
+ * array of all the full command names to allow for reasonably efficient
+ * handling of an unambiguous prefix.
*
* Results:
* None.
@@ -2574,7 +2561,7 @@ DeleteEnsembleConfig(
* Side effects:
* Reallocates and rebuilds the hash table and array stored at the
* ensemblePtr argument. For large ensembles or large namespaces, this is
- * a potentially expensive operation.
+ * may be an expensive operation.
*
*----------------------------------------------------------------------
*/
@@ -2583,10 +2570,10 @@ static void
BuildEnsembleConfig(
EnsembleConfig *ensemblePtr)
{
- Tcl_HashSearch search; /* Used for scanning the set of commands in
- * the namespace that backs up this
- * ensemble. */
- int i, j, isNew;
+ Tcl_HashSearch search; /* Used for scanning the commands in
+ * the namespace for this ensemble. */
+ int i, j;
+ int isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
@@ -2602,13 +2589,13 @@ BuildEnsembleConfig(
/*
* There is a list of exactly what subcommands go in the table.
- * Must determine the target for each.
+ * Determine the target for each.
*/
TclListObjGetElementsM(NULL, subList, &subc, &subv);
if (subList == mapDict) {
/*
- * Strange case where explicit list of subcommands is same value
+ * Unusual case where explicit list of subcommands is same value
* as the dict mapping to targets.
*/
@@ -2657,10 +2644,10 @@ BuildEnsembleConfig(
}
/*
- * target was not in the dictionary so map onto the namespace.
- * Note in this case that we do not guarantee that the command
- * is actually there; that is the programmer's responsibility
- * (or [::unknown] of course).
+ * Target was not in the dictionary. Map onto the namespace.
+ * In this case there is no guarantee that the command
+ * is actually there. It is the responsibility of the
+ * programmer (or [::unknown] of course) to provide the procedure.
*/
cmdObj = Tcl_NewStringObj(name, -1);
@@ -2671,9 +2658,9 @@ BuildEnsembleConfig(
}
} else if (mapDict) {
/*
- * No subcmd list, but we do have a mapping dictionary so we should
- * use the keys of that. Convert the dictionary's contents into the
- * form required for the ensemble's internal hashtable.
+ * No subcmd list, but there is a mapping dictionary, so
+ * use the keys of that. Convert the contents of the dictionary into the
+ * form required for the internal hashtable of the ensemble.
*/
Tcl_DictSearch dictSearch;
@@ -2692,18 +2679,15 @@ BuildEnsembleConfig(
}
} else {
/*
- * Discover what commands are actually exported by the namespace.
- * What we have is an array of patterns and a hash table whose keys
- * are the command names exported by the namespace (the contents do
- * not matter here.) We must find out what commands are actually
- * exported by filtering each command in the namespace against each of
- * the patterns in the export list. Note that we use an intermediate
- * hash table to make memory management easier, and because that makes
- * exact matching far easier too.
+ * Use the array of patterns and the hash table whose keys are the
+ * commands exported by the namespace. The corresponding values do not
+ * matter here. Filter the commands in the namespace against the
+ * patterns in the export list to find out what commands are actually
+ * exported. Use an intermediate hash table to make memory management
+ * easier and to make exact matching much easier.
*
- * Suggestion for future enhancement: compute the unique prefixes and
- * place them in the hash too, which should make for even faster
- * matching.
+ * Suggestion for future enhancement: Compute the unique prefixes and
+ * place them in the hash too for even faster matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
@@ -2748,22 +2732,22 @@ BuildEnsembleConfig(
/*
* Create a sorted array of all subcommands in the ensemble; hash tables
* are all very well for a quick look for an exact match, but they can't
- * determine things like whether a string is a prefix of another (not
- * without lots of preparation anyway) and they're no good for when we're
- * generating the error message either.
+ * determine things like whether a string is a prefix of another, at least
+ * not without a lot of preparation, and they're not useful for generating
+ * the error message either.
*
- * We do this by filling an array with the names (we use the hash keys
- * directly to save a copy, since any time we change the array we change
- * the hash too, and vice versa) and running quicksort over the array.
+ * Do this by filling an array with the names: Use the hash keys
+ * directly to save a copy since any time we change the array we change
+ * the hash too, and vice versa, and run quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr =
(char **)ckalloc(sizeof(char *) * hash->numEntries);
/*
- * Fill array from both ends as this makes us less likely to end up with
- * performance problems in qsort(), which is good. Note that doing this
- * makes this code much more opaque, but the naive alternatve:
+ * Fill the array from both ends as this reduces the likelihood of
+ * performance problems in qsort(). This makes this code much more opaque,
+ * but the naive alternatve:
*
* for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
* hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
@@ -2771,11 +2755,11 @@ BuildEnsembleConfig(
* }
*
* can produce long runs of precisely ordered table entries when the
- * commands in the namespace are declared in a sorted fashion (an ordering
- * some people like) and the hashing functions (or the command names
- * themselves) are fairly unfortunate. By filling from both ends, it
- * requires active malice (and probably a debugger) to get qsort() to have
- * awful runtime behaviour.
+ * commands in the namespace are declared in a sorted fashion, which is an
+ * ordering some people like, and the hashing functions or the command
+ * names themselves are fairly unfortunate. Filling from both ends means
+ * that it requires active malice, and probably a debugger, to get qsort()
+ * to have awful runtime behaviour.
*/
i = 0;
@@ -2801,8 +2785,7 @@ BuildEnsembleConfig(
*
* NsEnsembleStringOrder --
*
- * Helper function to compare two pointers to two strings for use with
- * qsort().
+ * Helper to for uset with sort() that compares two string pointers.
*
* Results:
* -1 if the first string is smaller, 1 if the second string is smaller,
@@ -2930,14 +2913,15 @@ TclCompileEnsemble(
Tcl_Obj *replaced, *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
Command *oldCmdPtr = cmdPtr, *newCmdPtr;
- int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
+ int result, flags = 0, depth = 1, invokeAnyway = 0;
int ourResult = TCL_ERROR;
- unsigned numBytes;
+ int i, len;
+ TCL_HASH_TYPE numBytes;
const char *word;
TclNewObj(replaced);
Tcl_IncrRefCount(replaced);
- if (parsePtr->numWords < depth + 1) {
+ if (parsePtr->numWords <= depth) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
@@ -3197,7 +3181,7 @@ TclCompileEnsemble(
* Throw out any line information generated by the failed compile attempt.
*/
- while (mapPtr->nuloc - 1 > eclIndex) {
+ while (mapPtr->nuloc > eclIndex + 1) {
mapPtr->nuloc--;
ckfree(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
@@ -3264,10 +3248,11 @@ TclAttemptCompileProc(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
- int result, i;
+ int result;
+ int i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
- unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
+ TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
@@ -3400,7 +3385,8 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
- int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ int i, numWords, length;
/*
* Push the words of the command. Take care; the command words may be
@@ -3411,9 +3397,9 @@ CompileToInvokedCommand(
TclListObjGetElementsM(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
- if (i > 0 && i < numWords+1) {
- bytes = TclGetString(words[i-1]);
- PushLiteral(envPtr, bytes, words[i-1]->length);
+ if (i > 0 && i <= numWords) {
+ bytes = TclGetStringFromObj(words[i-1], &length);
+ PushLiteral(envPtr, bytes, length);
continue;
}
@@ -3441,11 +3427,11 @@ CompileToInvokedCommand(
TclNewObj(objPtr);
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = TclGetString(objPtr);
+ bytes = TclGetStringFromObj(objPtr, &length);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
+ cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 923aae3..dd50be0 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -511,13 +511,13 @@ VarHashCreateVar(
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
((TclHasInternalRep((objPtr), &tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
- *(ptrPtr) = (ClientData) \
+ *(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
TclHasInternalRep((objPtr), &tclDoubleType) \
? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
- *(ptrPtr) = (ClientData) \
+ *(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
@@ -1348,7 +1348,7 @@ int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
- Tcl_Obj *objPtr, /* Points to Tcl object containing expression
+ Tcl_Obj *objPtr, /* Points to Tcl object containing expression
* to evaluate. */
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
@@ -1494,10 +1494,11 @@ CompileExprObj(
* TIP #280: No invoker (yet) - Expression compilation.
*/
- const char *string = TclGetString(objPtr);
+ int length;
+ const char *string = TclGetStringFromObj(objPtr, &length);
- TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
- TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
+ TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
+ TclCompileExpr(interp, string, length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
@@ -2105,8 +2106,8 @@ TEBCresume(
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
- int objc = 0;
- int opnd, length, pcAdjustment;
+ int length, objc = 0;
+ int opnd, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
@@ -3184,7 +3185,8 @@ TEBCresume(
*/
{
- int storeFlags, len;
+ int storeFlags;
+ int len;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -4660,7 +4662,7 @@ TEBCresume(
TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
O2S(valuePtr)));
- for (i=contextPtr->index ; i>=0 ; i--) {
+ for (i = contextPtr->index ; i >= 0 ; i--) {
miPtr = contextPtr->callPtr->chain + i;
if (miPtr->isFilter
|| miPtr->mPtr->declaringClassPtr != classPtr) {
@@ -4787,7 +4789,11 @@ TEBCresume(
Method *const mPtr =
contextPtr->callPtr->chain[newDepth].mPtr;
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, opnd, objv);
}
@@ -4829,8 +4835,8 @@ TEBCresume(
*/
{
- int index, numIndices, fromIdx, toIdx;
- int nocase, match, length2, cflags, s1len, s2len;
+ int numIndices, nocase, match, cflags;
+ int length2, fromIdx, toIdx, index, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
@@ -6866,7 +6872,8 @@ TEBCresume(
*/
{
- int opnd2, allocateDict, done, i, allocdict;
+ int opnd2, allocateDict, done, allocdict;
+ int i;
Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
Tcl_Obj *emptyPtr, **keyPtrPtr;
Tcl_DictSearch *searchPtr;
@@ -10046,7 +10053,7 @@ EvalStatsCmd(
#ifdef TCL_MEM_DEBUG
Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
- TclDumpMemoryInfo((ClientData) objPtr, 1);
+ TclDumpMemoryInfo(objPtr, 1);
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 585dc7b..5313eed 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4488,8 +4488,8 @@ Write(
}
}
}
- if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
- (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
+ if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) ||
+ (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) {
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
@@ -4749,7 +4749,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'.
@@ -4799,8 +4798,10 @@ Tcl_GetsObj(
skip++;
}
eol--;
+ ResetFlag(statePtr, INPUT_SAW_CR);
goto gotEOL;
} else if (*eol == '\n') {
+ ResetFlag(statePtr, INPUT_SAW_CR);
goto gotEOL;
}
}
@@ -4829,7 +4830,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 ee3dbf8..ac6fb54 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -913,7 +913,9 @@ typedef struct VarInHash {
*----------------------------------------------------------------
*/
-#if defined(__GNUC__) && (__GNUC__ > 2)
+#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)
+# define TCLFLEXARRAY
+#elif defined(__GNUC__) && (__GNUC__ > 2)
# define TCLFLEXARRAY 0
#else
# define TCLFLEXARRAY 1
@@ -2438,14 +2440,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) \
- (unsigned)(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.
@@ -2455,7 +2457,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 b87bf7c..4ce2f31 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1837,7 +1837,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 384fcf3..6bd65fa 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -95,7 +95,7 @@ typedef struct Link {
* 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) {
@@ -633,14 +633,15 @@ SetInvalidRealFromAny(
{
const char *str;
const char *endPtr;
+ int length;
- str = TclGetString(objPtr);
- if ((objPtr->length == 1) && (str[0] == '.')) {
+ str = TclGetStringFromObj(objPtr, &length);
+ if ((length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
- if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr,
+ 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
@@ -678,13 +679,14 @@ GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
- const char *str = TclGetString(objPtr);
+ int length;
+ const char *str = TclGetStringFromObj(objPtr, &length);
- if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0')
+ if ((length == 0) || ((length == 2) && (str[0] == '0')
&& strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
- } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
+ } else if ((length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
return TCL_OK;
}
@@ -743,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*/,
@@ -896,8 +898,8 @@ LinkTraceProc(
switch (linkPtr->type) {
case TCL_LINK_STRING:
- value = TclGetString(valueObj);
- valueLength = valueObj->length + 1;
+ value = TclGetStringFromObj(valueObj, &valueLength);
+ valueLength++; /* include end of string char */
pp = (char **) linkPtr->addr;
*pp = (char *)ckrealloc(*pp, valueLength);
@@ -905,7 +907,7 @@ LinkTraceProc(
return NULL;
case TCL_LINK_CHARS:
- value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
+ value = (char *) TclGetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index a7f723d..c24809e 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -77,20 +77,22 @@ const Tcl_ObjType tclListType = {
*
* NewListInternalRep --
*
- * Creates a list internal rep with space for objc elements. objc
- * must be > 0. If objv!=NULL, initializes with the first objc values
- * in that array. If objv==NULL, initalize list internal rep to have
- * 0 elements, with space to add objc more. Flag value "p" indicates
+ * Creates a 'List' structure with space for 'objc' elements. 'objc' must
+ * be > 0. If 'objv' is not NULL, The list is initialized with first
+ * 'objc' values in that array. Otherwise the list is initialized to have
+ * 0 elements, with space to add 'objc' more. Flag value 'p' indicates
* how to behave on failure.
*
- * Results:
- * A new List struct with refCount 0 is returned. If some failure
- * prevents this then if p=0, NULL is returned and otherwise the
- * routine panics.
+ * Value
*
- * Side effects:
- * The ref counts of the elements in objv are incremented since the
- * resulting list now refers to them.
+ * A new 'List' structure with refCount 0. If some failure
+ * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic'
+ * is called if it is not.
+ *
+ * Effect
+ *
+ * The refCount of each value in 'objv' is incremented as it is added
+ * to the list.
*
*----------------------------------------------------------------------
*/
@@ -140,7 +142,7 @@ NewListInternalRep(
int i;
listRepPtr->elemCount = objc;
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
for (i = 0; i < objc; i++) {
elemPtrs[i] = objv[i];
Tcl_IncrRefCount(elemPtrs[i]);
@@ -154,21 +156,9 @@ NewListInternalRep(
/*
*----------------------------------------------------------------------
*
- * AttemptNewList --
+ * AttemptNewList --
*
- * Creates a list internal rep with space for objc elements. objc
- * must be > 0. If objv!=NULL, initializes with the first objc values
- * in that array. If objv==NULL, initalize list internal rep to have
- * 0 elements, with space to add objc more.
- *
- * Results:
- * A new List struct with refCount 0 is returned. If some failure
- * prevents this then NULL is returned, and an error message is left
- * in the interp result, unless interp is NULL.
- *
- * Side effects:
- * The ref counts of the elements in objv are incremented since the
- * resulting list now refers to them.
+ * Like NewListInternalRep, but additionally sets an error message on failure.
*
*----------------------------------------------------------------------
*/
@@ -201,23 +191,20 @@ AttemptNewList(
*
* Tcl_NewListObj --
*
- * This function is normally called when not debugging: i.e., when
- * TCL_MEM_DEBUG is not defined. It creates a new list object from an
- * (objc,objv) array: that is, each of the objc elements of the array
- * referenced by objv is inserted as an element into a new Tcl object.
+ * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is
+ * defined, 'Tcl_DbNewListObj' is called instead.
*
- * When TCL_MEM_DEBUG is defined, this function just returns the result
- * of calling the debugging version Tcl_DbNewListObj.
+ * Value
*
- * Results:
- * A new list object is returned that is initialized from the object
- * pointers in objv. If objc is less than or equal to zero, an empty
- * object is returned. The new object's string representation is left
- * NULL. The resulting new list object has ref count 0.
+ * A new list 'Tcl_Obj' to which is appended values from 'objv', or if
+ * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no
+ * elements. The string representation of the new 'Tcl_Obj' is set to
+ * NULL. The refCount of the list is 0.
*
- * Side effects:
- * The ref counts of the elements in objv are incremented since the
- * resulting list now refers to them.
+ * Effect
+ *
+ * The refCount of each elements in 'objv' is incremented as it is added
+ * to the list.
*
*----------------------------------------------------------------------
*/
@@ -268,28 +255,14 @@ Tcl_NewListObj(
/*
*----------------------------------------------------------------------
*
- * Tcl_DbNewListObj --
- *
- * This function is normally called when debugging: i.e., when
- * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
- * as the Tcl_NewListObj function above except that it calls
- * Tcl_DbCkalloc directly with the file name and line number from its
- * caller. This simplifies debugging since then the [memory active]
- * command will report the correct file name and line number when
- * reporting objects that haven't been freed.
+ * Tcl_DbNewListObj --
*
- * When TCL_MEM_DEBUG is not defined, this function just returns the
- * result of calling Tcl_NewListObj.
+ * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the
+ * file name and line number from its caller. This simplifies debugging
+ * since the [memory active] command will report the correct file
+ * name and line number when reporting objects that haven't been freed.
*
- * Results:
- * A new list object is returned that is initialized from the object
- * pointers in objv. If objc is less than or equal to zero, an empty
- * object is returned. The new object's string representation is left
- * NULL. The new list object has ref count 0.
- *
- * Side effects:
- * The ref counts of the elements in objv are incremented since the
- * resulting list now refers to them.
+ * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead.
*
*----------------------------------------------------------------------
*/
@@ -348,19 +321,8 @@ Tcl_DbNewListObj(
*
* Tcl_SetListObj --
*
- * Modify an object to be a list containing each of the objc elements of
- * the object array referenced by objv.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object is made a list object and is initialized from the object
- * pointers in objv. If objc is less than or equal to zero, an empty
- * object is returned. The new object's string representation is left
- * NULL. The ref counts of the elements in objv are incremented since the
- * list now refers to them. The object's old string and internal
- * representations are freed and its type is set NULL.
+ * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of
+ * creating a new one.
*
*----------------------------------------------------------------------
*/
@@ -403,18 +365,20 @@ 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.
+ * Creates a new 'Tcl_Obj' which is a pure 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.
+ * Value
*
- * Side effects:
- * None.
+ * The address of the new 'Tcl_Obj' which shares its internal
+ * representation with 'listPtr', and whose refCount is 0. If 'listPtr'
+ * is not actually a list, the value is NULL, and an error message is left
+ * in 'interp' if it is not NULL.
+ *
+ * Effect
+ *
+ * 'listPtr' is converted to a list if it isn't one already.
*
*----------------------------------------------------------------------
*/
@@ -529,27 +493,30 @@ TclListObjRange(
*
* Tcl_ListObjGetElements --
*
- * This function returns an (objc,objv) array of the elements in a list
- * object.
+ * Retreive the elements in a list 'Tcl_Obj'.
*
- * Results:
- * The return value is normally TCL_OK; in this case *objcPtr is set to
- * the count of list elements and *objvPtr is set to a pointer to an
- * array of (*objcPtr) pointers to each list element. If listPtr does not
- * refer to a list object and the object can not be converted to one,
- * TCL_ERROR is returned and an error message will be left in the
- * interpreter's result if interp is not NULL.
- *
- * The objects referenced by the returned array should be treated as
- * readonly and their ref counts are _not_ incremented; the caller must
- * do that if it holds on to a reference. Furthermore, the pointer and
- * length returned by this function may change as soon as any function is
- * called on the list object; be careful about retaining the pointer in a
- * local data structure.
+ * Value
*
- * Side effects:
- * The possible conversion of the object referenced by listPtr
- * to a list object.
+ * TCL_OK
+ *
+ * A count of list elements is stored, 'objcPtr', And a pointer to the
+ * array of elements in the list is stored in 'objvPtr'.
+ *
+ * The elements accessible via 'objvPtr' should be treated as readonly
+ * and the refCount for each object is _not_ incremented; the caller
+ * must do that if it holds on to a reference. Furthermore, the
+ * pointer and length returned by this function may change as soon as
+ * any function is called on the list object. Be careful about
+ * retaining the pointer in a local data structure.
+ *
+ * TCL_ERROR
+ *
+ * 'listPtr' is not a valid list. An error message is left in the
+ * interpreter's result if 'interp' is not NULL.
+ *
+ * Effect
+ *
+ * 'listPtr' is converted to a list object if it isn't one already.
*
*----------------------------------------------------------------------
*/
@@ -570,7 +537,8 @@ Tcl_ListObjGetElements(
ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
- int result, length;
+ int result;
+ int length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
@@ -585,7 +553,7 @@ Tcl_ListObjGetElements(
ListGetInternalRep(listPtr, listRepPtr);
}
*objcPtr = listRepPtr->elemCount;
- *objvPtr = &listRepPtr->elements;
+ *objvPtr = listRepPtr->elements;
return TCL_OK;
}
@@ -594,20 +562,27 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * This function appends the elements in the list value referenced by
- * elemListPtr to the list value referenced by listPtr.
+ * Appends the elements of elemListPtr to those of listPtr.
*
- * Results:
- * The return value is normally TCL_OK. If listPtr or elemListPtr do not
- * refer to list values, TCL_ERROR is returned and an error message is
- * left in the interpreter's result if interp is not NULL.
+ * Value
*
- * Side effects:
- * The reference counts of the elements in elemListPtr are incremented
- * since the list now refers to them. listPtr and elemListPtr are
- * converted, if necessary, to list objects. Also, appending the new
- * elements may cause listObj's array of element pointers to grow.
- * listPtr's old string representation, if any, is invalidated.
+ * TCL_OK
+ *
+ * Success.
+ *
+ * TCL_ERROR
+ *
+ * 'listPtr' or 'elemListPtr' are not valid lists. An error
+ * message is left in the interpreter's result if 'interp' is not NULL.
+ *
+ * Effect
+ *
+ * The reference count of each element of 'elemListPtr' as it is added to
+ * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType'
+ * if they are not already. Appending the new elements may cause the
+ * array of element pointers in 'listObj' to grow. If any objects are
+ * appended to 'listPtr'. Any preexisting string representation of
+ * 'listPtr' is invalidated.
*
*----------------------------------------------------------------------
*/
@@ -646,24 +621,27 @@ Tcl_ListObjAppendList(
*
* Tcl_ListObjAppendElement --
*
- * This function is a special purpose version of Tcl_ListObjAppendList:
- * it appends a single object referenced by objPtr to the list object
- * referenced by listPtr. If listPtr is not already a list object, an
- * attempt will be made to convert it to one.
+ * Like 'Tcl_ListObjAppendList', but Appends a single value to a list.
*
- * Results:
- * The return value is normally TCL_OK; in this case objPtr is added to
- * the end of listPtr's list. If listPtr does not refer to a list object
- * and the object can not be converted to one, TCL_ERROR is returned and
- * an error message will be left in the interpreter's result if interp is
- * not NULL.
+ * Value
*
- * Side effects:
- * The ref count of objPtr is incremented since the list now refers to
- * it. listPtr will be converted, if necessary, to a list object. Also,
- * appending the new element may cause listObj's array of element
- * pointers to grow. listPtr's old string representation, if any, is
- * invalidated.
+ * TCL_OK
+ *
+ * 'objPtr' is appended to the elements of 'listPtr'.
+ *
+ * TCL_ERROR
+ *
+ * listPtr does not refer to a list object and the object can not be
+ * converted to one. An error message will be left in the
+ * interpreter's result if interp is not NULL.
+ *
+ * Effect
+ *
+ * If 'listPtr' is not already of type 'tclListType', it is converted.
+ * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'.
+ * Appending the new element may cause the the array of element pointers
+ * in 'listObj' to grow. Any preexisting string representation of
+ * 'listPtr' is invalidated.
*
*----------------------------------------------------------------------
*/
@@ -675,7 +653,8 @@ Tcl_ListObjAppendElement(
Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
{
List *listRepPtr, *newPtr = NULL;
- int numElems, numRequired, needGrow, isShared, attempt;
+ int numElems, numRequired;
+ int needGrow, isShared, attempt;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
@@ -683,7 +662,8 @@ Tcl_ListObjAppendElement(
ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
- int result, length;
+ int result;
+ int length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
@@ -739,7 +719,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
@@ -767,7 +747,7 @@ Tcl_ListObjAppendElement(
return TCL_ERROR;
}
- dst = &newPtr->elements;
+ dst = newPtr->elements;
newPtr->refCount++;
newPtr->canonicalFlag = listRepPtr->canonicalFlag;
newPtr->elemCount = listRepPtr->elemCount;
@@ -803,7 +783,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++;
@@ -821,23 +801,27 @@ Tcl_ListObjAppendElement(
*
* Tcl_ListObjIndex --
*
- * This function returns a pointer to the index'th object from the list
- * referenced by listPtr. The first element has index 0. If index is
- * negative or greater than or equal to the number of elements in the
- * list, a NULL is returned. If listPtr is not a list object, an attempt
- * will be made to convert it to a list.
+ * Retrieve a pointer to the element of 'listPtr' at 'index'. The index
+ * of the first element is 0.
*
- * Results:
- * The return value is normally TCL_OK; in this case objPtrPtr is set to
- * the Tcl_Obj pointer for the index'th list element or NULL if index is
- * out of range. This object should be treated as readonly and its ref
- * count is _not_ incremented; the caller must do that if it holds on to
- * the reference. If listPtr does not refer to a list and can't be
- * converted to one, TCL_ERROR is returned and an error message is left
- * in the interpreter's result if interp is not NULL.
+ * Value
*
- * Side effects:
- * listPtr will be converted, if necessary, to a list object.
+ * TCL_OK
+ *
+ * A pointer to the element at 'index' is stored in 'objPtrPtr'. If
+ * 'index' is out of range, NULL is stored in 'objPtrPtr'. This
+ * object should be treated as readonly and its 'refCount' is _not_
+ * incremented. The caller must do that if it holds on to the
+ * reference.
+ *
+ * TCL_ERROR
+ *
+ * 'listPtr' is not a valid list. An an error message is left in the
+ * interpreter's result if 'interp' is not NULL.
+ *
+ * Effect
+ *
+ * If 'listPtr' is not already of type 'tclListType', it is converted.
*
*----------------------------------------------------------------------
*/
@@ -853,7 +837,8 @@ Tcl_ListObjIndex(
ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
- int result, length;
+ int result;
+ int length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
@@ -870,7 +855,7 @@ Tcl_ListObjIndex(
if ((index < 0) || (index >= listRepPtr->elemCount)) {
*objPtrPtr = NULL;
} else {
- *objPtrPtr = (&listRepPtr->elements)[index];
+ *objPtrPtr = listRepPtr->elements[index];
}
return TCL_OK;
@@ -881,19 +866,20 @@ Tcl_ListObjIndex(
*
* Tcl_ListObjLength --
*
- * This function returns the number of elements in a list object. If the
- * object is not already a list object, an attempt will be made to
- * convert it to one.
+ * Retrieve the number of elements in a list.
*
- * Results:
- * The return value is normally TCL_OK; in this case *intPtr will be set
- * to the integer count of list elements. If listPtr does not refer to a
- * list object and the object can not be converted to one, TCL_ERROR is
- * returned and an error message will be left in the interpreter's result
- * if interp is not NULL.
+ * Value
*
- * Side effects:
- * The possible conversion of the argument object to a list object.
+ * TCL_OK
+ *
+ * A count of list elements is stored at the address provided by
+ * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is
+ * converted.
+ *
+ * TCL_ERROR
+ *
+ * 'listPtr' is not a valid list. An error message will be left in
+ * the interpreter's result if 'interp' is not NULL.
*
*----------------------------------------------------------------------
*/
@@ -903,13 +889,14 @@ int
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object whose #elements to return. */
- int *intPtr) /* The resulting int is stored here. */
+ int *intPtr) /* The resulting length is stored here. */
{
List *listRepPtr;
ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
- int result, length;
+ int result;
+ int length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
@@ -932,35 +919,36 @@ Tcl_ListObjLength(
*
* Tcl_ListObjReplace --
*
- * This function replaces zero or more elements of the list referenced by
- * listPtr with the objects from an (objc,objv) array. The objc elements
- * of the array referenced by objv replace the count elements in listPtr
- * starting at first.
+ * Replace values in a list.
*
- * If the argument first is zero or negative, it refers to the first
- * element. If first is greater than or equal to the number of elements
- * in the list, then no elements are deleted; the new elements are
- * appended to the list. Count gives the number of elements to replace.
- * If count is zero or negative then no elements are deleted; the new
- * elements are simply inserted before first.
+ * If 'first' is zero or TCL_INDEX_NONE, it refers to the first element. If
+ * 'first' outside the range of elements in the list, no elements are
+ * deleted.
*
- * The argument objv refers to an array of objc pointers to the new
- * elements to be added to listPtr in place of those that were deleted.
- * If objv is NULL, no new elements are added. If listPtr is not a list
- * object, an attempt will be made to convert it to one.
+ * If 'count' is zero or TCL_INDEX_NONE no elements are deleted, and any new
+ * elements are inserted at the beginning of the list.
*
- * Results:
- * The return value is normally TCL_OK. If listPtr does not refer to a
- * list object and can not be converted to one, TCL_ERROR is returned and
- * an error message will be left in the interpreter's result if interp is
- * not NULL.
+ * Value
*
- * Side effects:
- * The ref counts of the objc elements in objv are incremented since the
- * resulting list now refers to them. Similarly, the ref counts for
- * replaced objects are decremented. listPtr is converted, if necessary,
- * to a list object. listPtr's old string representation, if any, is
- * freed.
+ * TCL_OK
+ *
+ * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr'
+ * starting at 'first'. If 'objc' 0, no new elements are added.
+ *
+ * TCL_ERROR
+ *
+ * 'listPtr' is not a valid list. An error message is left in the
+ * interpreter's result if 'interp' is not NULL.
+ *
+ * Effect
+ *
+ * If 'listPtr' is not of type 'tclListType', it is converted if possible.
+ *
+ * The 'refCount' of each element appended to the list is incremented.
+ * Similarly, the 'refCount' for each replaced element is decremented.
+ *
+ * If 'listPtr' is modified, any previous string representation is
+ * invalidated.
*
*----------------------------------------------------------------------
*/
@@ -977,7 +965,8 @@ Tcl_ListObjReplace(
{
List *listRepPtr;
Tcl_Obj **elemPtrs;
- int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
+ int numElems, numRequired, numAfterLast, start, i, j;
+ int needGrow, isShared;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
@@ -1011,7 +1000,7 @@ Tcl_ListObjReplace(
* Resist any temptation to optimize this case.
*/
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
if (first < 0) {
@@ -1065,7 +1054,7 @@ Tcl_ListObjReplace(
if (newPtr) {
listRepPtr = newPtr;
ListResetInternalRep(listPtr, listRepPtr);
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
listRepPtr->maxElemCount = attempt;
needGrow = numRequired > listRepPtr->maxElemCount;
}
@@ -1140,7 +1129,7 @@ Tcl_ListObjReplace(
ListResetInternalRep(listPtr, listRepPtr);
listRepPtr->refCount++;
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
if (isShared) {
/*
@@ -1228,22 +1217,19 @@ Tcl_ListObjReplace(
*
* TclLindexList --
*
- * This procedure handles the 'lindex' command when objc==3.
+ * Implements the 'lindex' command when objc==3.
*
- * Results:
- * Returns a pointer to the object extracted, or NULL if an error
- * occurred. The returned object already includes one reference count for
- * the pointer returned.
+ * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures
+ * the argument format into required form while taking care to manage
+ * shimmering so as to tend to keep the most useful internalreps
+ * and/or avoid the most expensive conversions.
*
- * Side effects:
- * None.
+ * Value
*
- * Notes:
- * This procedure is implemented entirely as a wrapper around
- * TclLindexFlat. All it does is reconfigure the argument format into the
- * form required by TclLindexFlat, while taking care to manage shimmering
- * in such a way that we tend to keep the most useful internalreps and/or
- * avoid the most expensive conversions.
+ * A pointer to the specified element, with its 'refCount' incremented, or
+ * NULL if an error occurred.
+ *
+ * Notes
*
*----------------------------------------------------------------------
*/
@@ -1302,7 +1288,7 @@ TclLindexList(
assert(listRepPtr != NULL);
listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
- &listRepPtr->elements);
+ listRepPtr->elements);
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
@@ -1310,25 +1296,20 @@ TclLindexList(
/*
*----------------------------------------------------------------------
*
- * TclLindexFlat --
+ * TclLindexFlat --
*
- * This procedure is the core of the 'lindex' command, with all index
- * arguments presented as a flat list.
+ * The core of the 'lindex' command, with all index
+ * arguments presented as a flat list.
*
- * Results:
- * Returns a pointer to the object extracted, or NULL if an error
- * occurred. The returned object already includes one reference count for
- * the pointer returned.
+ * Value
*
- * Side effects:
- * None.
+ * A pointer to the object extracted, with its 'refCount' incremented, or
+ * NULL if an error occurred. Thus, the calling code will usually do
+ * something like:
+ *
+ * Tcl_SetObjResult(interp, result);
+ * Tcl_DecrRefCount(result);
*
- * Notes:
- * The reference count of the returned object includes one reference
- * corresponding to the pointer returned. Thus, the calling code will
- * usually do something like:
- * Tcl_SetObjResult(interp, result);
- * Tcl_DecrRefCount(result);
*
*----------------------------------------------------------------------
*/
@@ -1404,24 +1385,17 @@ TclLindexFlat(
*
* TclLsetList --
*
- * Core of the 'lset' command when objc == 4. Objv[2] may be either a
+ * The core of [lset] when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
* It also handles 'lpop' when given a NULL value.
*
- * Results:
- * Returns the new value of the list variable, or NULL if there was an
- * error. The returned object includes one reference count for the
- * pointer returned.
+ * Implemented entirely as a wrapper around 'TclLindexFlat', as described
+ * for 'TclLindexList'.
*
- * Side effects:
- * None.
+ * Value
*
- * Notes:
- * This procedure is implemented entirely as a wrapper around
- * TclLsetFlat. All it does is reconfigure the argument format into the
- * form required by TclLsetFlat, while taking care to manage shimmering
- * in such a way that we tend to keep the most useful internalreps and/or
- * avoid the most expensive conversions.
+ * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if
+ * there was an error.
*
*----------------------------------------------------------------------
*/
@@ -1486,36 +1460,39 @@ TclLsetList(
* Core engine of the 'lset' command.
* It also handles 'lpop' when given a NULL value.
*
- * Results:
- * Returns the new value of the list variable, or NULL if an error
- * occurred. The returned object includes one reference count for the
- * pointer returned.
+ * Value
*
- * Side effects:
- * On entry, the reference count of the variable value does not reflect
- * any references held on the stack. The first action of this function is
- * to determine whether the object is shared, and to duplicate it if it
- * is. The reference count of the duplicate is incremented. At this
- * point, the reference count will be 1 for either case, so that the
- * object will appear to be unshared.
- *
- * If an error occurs, and the object has been duplicated, the reference
- * count on the duplicate is decremented so that it is now 0: this
- * dismisses any memory that was allocated by this function.
- *
- * If no error occurs, the reference count of the original object is
- * incremented if the object has not been duplicated, and nothing is done
- * to a reference count of the duplicate. Now the reference count of an
- * unduplicated object is 2 (the returned pointer, plus the one stored in
- * the variable). The reference count of a duplicate object is 1,
- * reflecting that the returned pointer is the only active reference. The
- * caller is expected to store the returned value back in the variable
- * and decrement its reference count. (INST_STORE_* does exactly this.)
- *
- * Surgery is performed on the unshared list value to produce the result.
- * TclLsetFlat maintains a linked list of Tcl_Obj's whose string
+ * The resulting list
+ *
+ * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not
+ * duplicated, its 'refCount' is incremented. The reference count of
+ * an unduplicated object is therefore 2 (one for the returned pointer
+ * and one for the variable that holds it). The reference count of a
+ * duplicate object is 1, reflecting that result is the only active
+ * reference. The caller is expected to store the result in the
+ * variable and decrement its reference count. (INST_STORE_* does
+ * exactly this.)
+ *
+ * NULL
+ *
+ * An error occurred. If 'listPtr' was duplicated, the reference
+ * count on the duplicate is decremented so that it is 0, causing any
+ * memory allocated by this function to be freed.
+ *
+ *
+ * Effect
+ *
+ * On entry, the reference count of 'listPtr' does not reflect any
+ * references held on the stack. The first action of this function is to
+ * determine whether 'listPtr' is shared and to create a duplicate
+ * unshared copy if it is. The reference count of the duplicate is
+ * incremented. At this point, the reference count is 1 in either case so
+ * that the object is considered unshared.
+ *
+ * The unshared list is altered directly to produce the result.
+ * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string
* representations must be spoilt by threading via 'ptr2' of the
- * two-pointer internal representation. On entry to TclLsetFlat, the
+ * two-pointer internal representation. On entry to 'TclLsetFlat', the
* values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
* Tcl_Obj that has been modified is set to NULL.
*
@@ -1531,7 +1508,8 @@ TclLsetFlat(
/* Index args. */
Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
- int index, result, len;
+ int index, len;
+ int result;
Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
Tcl_ObjInternalRep *irPtr;
@@ -1724,12 +1702,12 @@ TclLsetFlat(
}
/*
- * Store valuePtr in proper sublist and return. The -1 is to avoid a
- * compiler warning (not a problem because we checked that we have a
- * proper list - or something convertible to one - above).
+ * Store valuePtr in proper sublist and return. The TCL_INDEX_NONE is
+ * to avoid a compiler warning (not a problem because we checked that
+ * we have a proper list - or something convertible to one - above).
*/
- len = -1;
+ len = TCL_INDEX_NONE;
TclListObjLengthM(NULL, subListPtr, &len);
if (valuePtr == NULL) {
Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL);
@@ -1748,26 +1726,38 @@ TclLsetFlat(
*
* TclListObjSetElement --
*
- * Set a single element of a list to a specified value
+ * Set a single element of a list to a specified value.
*
- * Results:
- * The return value is normally TCL_OK. If listPtr does not refer to a
- * list object and cannot be converted to one, TCL_ERROR is returned and
- * an error message will be left in the interpreter result if interp is
- * not NULL. Similarly, if index designates an element outside the range
- * [0..listLength-1], where listLength is the count of elements in the
- * list object designated by listPtr, TCL_ERROR is returned and an error
- * message is left in the interpreter result.
+ * It is the caller's responsibility to invalidate the string
+ * representation of the 'listPtr'.
*
- * Side effects:
- * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts
- * to convert it to a list with a non-shared internal rep. Decrements the
- * ref count of the object at the specified index within the list,
- * replaces with the object designated by valuePtr, and increments the
- * ref count of the replacement object.
+ * Value
+ *
+ * TCL_OK
+ *
+ * Success.
+ *
+ * TCL_ERROR
+ *
+ * 'listPtr' does not refer to a list object and cannot be converted
+ * to one. An error message will be left in the interpreter result if
+ * interp is not NULL.
+ *
+ * TCL_ERROR
+ *
+ * An index designates an element outside the range [0..listLength-1],
+ * where 'listLength' is the count of elements in the list object
+ * designated by 'listPtr'. An error message is left in the
+ * interpreter result.
+ *
+ * Effect
+ *
+ * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If
+ * 'listPtr' is not already of type 'tclListType', it is converted and the
+ * internal representation is unshared. The 'refCount' of the element at
+ * 'index' is decremented and replaced in the list with the 'valuePtr',
+ * whose 'refCount' in turn is incremented.
*
- * It is the caller's responsibility to invalidate the string
- * representation of the object.
*
*----------------------------------------------------------------------
*/
@@ -1797,7 +1787,8 @@ TclListObjSetElement(
ListGetInternalRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
- int result, length;
+ int result;
+ int length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
@@ -1837,7 +1828,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) {
@@ -1850,7 +1841,7 @@ TclListObjSetElement(
newPtr->elemCount = elemCount;
newPtr->canonicalFlag = listRepPtr->canonicalFlag;
- dst = &newPtr->elements;
+ dst = newPtr->elements;
while (elemCount--) {
*dst = *src++;
Tcl_IncrRefCount(*dst++);
@@ -1861,7 +1852,7 @@ TclListObjSetElement(
listRepPtr = newPtr;
ListResetInternalRep(listPtr, listRepPtr);
}
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
/*
* Add a reference to the new list element.
@@ -1901,13 +1892,11 @@ TclListObjSetElement(
*
* FreeListInternalRep --
*
- * Deallocate the storage associated with a list object's internal
- * representation.
+ * Deallocate the storage associated with the internal representation of a
+ * a list object.
*
- * Results:
- * None.
+ * Effect
*
- * Side effects:
* Frees listPtr's List* internal representation, if no longer shared.
* May decrement the ref counts of element objects, which may free them.
*
@@ -1924,7 +1913,7 @@ FreeListInternalRep(
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++) {
@@ -1939,14 +1928,12 @@ FreeListInternalRep(
*
* DupListInternalRep --
*
- * Initialize the internal representation of a list Tcl_Obj to share the
+ * Initialize the internal representation of a list 'Tcl_Obj' to share the
* internal representation of an existing list object.
*
- * Results:
- * None.
+ * Effect
*
- * Side effects:
- * The reference count of the List internal rep is incremented.
+ * The 'refCount' of the List internal rep is incremented.
*
*----------------------------------------------------------------------
*/
@@ -1968,16 +1955,20 @@ DupListInternalRep(
*
* SetListFromAny --
*
- * Attempt to generate a list internal form for the Tcl object "objPtr".
+ * Convert any object to a list.
*
- * Results:
- * The return value is TCL_OK or TCL_ERROR. If an error occurs during
- * conversion, an error message is left in the interpreter's result
- * unless "interp" is NULL.
+ * Value
+ *
+ * TCL_OK
+ *
+ * Success. The internal representation of 'objPtr' is set, and the type
+ * of 'objPtr' is 'tclListType'.
+ *
+ * TCL_ERROR
+ *
+ * An error occured during conversion. An error message is left in the
+ * interpreter's result if 'interp' is not NULL.
*
- * Side effects:
- * If no error occurs, a list is stored as "objPtr"s internal
- * representation.
*
*----------------------------------------------------------------------
*/
@@ -2001,7 +1992,8 @@ SetListFromAny(
if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) {
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
- int done, size;
+ int done;
+ int size;
/*
* Create the new list representation. Note that we do not need to do
@@ -2023,7 +2015,7 @@ SetListFromAny(
* Populate the list representation.
*/
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
while (!done) {
*elemPtrs++ = keyPtr;
@@ -2048,7 +2040,7 @@ SetListFromAny(
if (listRepPtr == NULL) {
return TCL_ERROR;
}
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
/*
* Each iteration, parse and store a list element.
@@ -2057,12 +2049,13 @@ SetListFromAny(
while (nextElem < limit) {
const char *elemStart;
char *check;
- int elemSize, literal;
+ int elemSize;
+ int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
fail:
- while (--elemPtrs >= &listRepPtr->elements) {
+ while (--elemPtrs >= listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
ckfree(listRepPtr);
@@ -2092,7 +2085,7 @@ SetListFromAny(
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
- listRepPtr->elemCount = elemPtrs - &listRepPtr->elements;
+ listRepPtr->elemCount = elemPtrs - listRepPtr->elements;
}
/*
@@ -2110,18 +2103,16 @@ SetListFromAny(
*
* UpdateStringOfList --
*
- * Update the string representation for a list object. Note: This
- * function does not invalidate an existing old string rep so storage
- * will be lost if this has not already been done.
+ * Update the string representation for a list object.
*
- * Results:
- * None.
+ * Any previously-exising string representation is not invalidated, so
+ * storage is lost if this has not been taken care of.
*
- * Side effects:
- * The object's string is set to a valid string that results from the
- * list-to-string conversion. This string will be empty if the list has
- * no elements. The list internal representation should not be NULL and
- * we assume it is not NULL.
+ * Effect
+ *
+ * The string representation of 'listPtr' is set to the resulting string.
+ * This string will be empty if the list has no elements. It is assumed
+ * that the list internal representation is not NULL.
*
*----------------------------------------------------------------------
*/
@@ -2174,7 +2165,7 @@ UpdateStringOfList(
flagPtr = (char *)ckalloc(numElems);
}
- elemPtrs = &listRepPtr->elements;
+ elemPtrs = listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 8613e98..e17819e 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -96,7 +96,7 @@ TCL_DECLARE_MUTEX(listLock)
*/
static int QueueEvent(ThreadSpecificData *tsdPtr,
- Tcl_Event *evPtr, int flags);
+ Tcl_Event *evPtr, int position);
/*
*----------------------------------------------------------------------
@@ -175,8 +175,7 @@ TclFinalizeNotifier(void)
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
- return; /* Notifier not initialized for the current
- * thread. */
+ return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
@@ -310,7 +309,7 @@ Tcl_CreateEventSource(
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));
+ EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
@@ -392,12 +391,12 @@ Tcl_QueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- (void) QueueEvent(tsdPtr, evPtr, flags);
+ QueueEvent(tsdPtr, evPtr, position);
}
/*
@@ -424,8 +423,8 @@ Tcl_ThreadQueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- int flags) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
- * TCL_QUEUE_MARK, possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
+ * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */
{
ThreadSpecificData *tsdPtr;
@@ -444,7 +443,7 @@ Tcl_ThreadQueueEvent(
*/
if (tsdPtr) {
- if (QueueEvent(tsdPtr, evPtr, flags)) {
+ if (QueueEvent(tsdPtr, evPtr, position)) {
Tcl_AlertNotifier(tsdPtr->clientData);
}
} else {
@@ -484,15 +483,14 @@ QueueEvent(
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
- int flags)
- /* One of TCL_QUEUE_TAIL_EX,
- * TCL_QUEUE_HEAD_EX, TCL_QUEUE_MARK_EX,
+ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK,
* possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */
{
- int wasEmpty = 0;
-
Tcl_MutexLock(&(tsdPtr->queueMutex));
- if ((flags & 3) == TCL_QUEUE_TAIL) {
+ if (tsdPtr->firstEventPtr != NULL) {
+ position &= ~TCL_QUEUE_ALERT_IF_EMPTY;
+ }
+ if ((position & 3) == TCL_QUEUE_TAIL) {
/*
* Append the event on the end of the queue.
*/
@@ -500,12 +498,11 @@ QueueEvent(
evPtr->nextPtr = NULL;
if (tsdPtr->firstEventPtr == NULL) {
tsdPtr->firstEventPtr = evPtr;
- wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0;
} else {
tsdPtr->lastEventPtr->nextPtr = evPtr;
}
tsdPtr->lastEventPtr = evPtr;
- } else if ((flags & 3) == TCL_QUEUE_HEAD) {
+ } else if ((position & 3) == TCL_QUEUE_HEAD) {
/*
* Push the event on the head of the queue.
*/
@@ -513,10 +510,9 @@ QueueEvent(
evPtr->nextPtr = tsdPtr->firstEventPtr;
if (tsdPtr->firstEventPtr == NULL) {
tsdPtr->lastEventPtr = evPtr;
- wasEmpty = (flags & TCL_QUEUE_ALERT_IF_EMPTY) ? 1 : 0;
}
tsdPtr->firstEventPtr = evPtr;
- } else if ((flags & 3) == TCL_QUEUE_MARK) {
+ } else if ((position & 3) == TCL_QUEUE_MARK) {
/*
* Insert the event after the current marker event and advance the
* marker to the new event.
@@ -535,7 +531,7 @@ QueueEvent(
}
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
- return wasEmpty;
+ return position & TCL_QUEUE_ALERT_IF_EMPTY;
}
/*
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0cd08d2..5bd687a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -391,9 +391,9 @@ InitFoundation(
*/
TclNewLiteralStringObj(namePtr, "new");
- Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
- fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+ fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp,
(Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
/*
@@ -2246,7 +2246,7 @@ CloneObjectMethod(
Tcl_Obj *namePtr)
{
if (mPtr->typePtr == NULL) {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2255,10 +2255,10 @@ CloneObjectMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
} else {
- Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
}
return TCL_OK;
@@ -2275,7 +2275,7 @@ CloneClassMethod(
Method *m2Ptr;
if (mPtr->typePtr == NULL) {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
} else if (mPtr->typePtr->cloneProc) {
ClientData newClientData;
@@ -2284,11 +2284,11 @@ CloneClassMethod(
&newClientData) != TCL_OK) {
return TCL_ERROR;
}
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
newClientData);
} else {
- m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr,
namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
mPtr->clientData);
}
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index c6ffccd..c933872 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -135,6 +135,20 @@ declare 30 {
declare 31 {
Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object)
}
+declare 32 {
+ int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+}
+declare 33 {
+ Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
+}
+declare 34 {
+ Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData)
+}
######################################################################
# Private API, exposed to support advanced OO systems that plug in on top of
diff --git a/generic/tclOO.h b/generic/tclOO.h
index 4a3398f..6f18491 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,8 +24,8 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.2.0"
-#define TCLOO_PATCHLEVEL TCLOO_VERSION
+#define TCLOO_VERSION "1.3"
+#define TCLOO_PATCHLEVEL TCLOO_VERSION ".0"
#include "tcl.h"
@@ -40,7 +40,7 @@ extern "C" {
extern const char *TclOOInitializeStubs(
Tcl_Interp *, const char *version);
#define Tcl_OOInitStubs(interp) \
- TclOOInitializeStubs((interp), TCLOO_VERSION)
+ TclOOInitializeStubs((interp), TCLOO_PATCHLEVEL)
#ifndef USE_TCL_STUBS
# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL)
#endif
@@ -62,6 +62,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext;
typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp,
Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv);
+typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp,
+ Tcl_ObjectContext objectContext, size_t objc, Tcl_Obj *const *objv);
typedef void (Tcl_MethodDeleteProc)(void *clientData);
typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData,
void **newClientData);
@@ -77,7 +79,7 @@ typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp,
typedef struct {
int version; /* Structure version field. Always to be equal
- * to TCL_OO_METHOD_VERSION_CURRENT in
+ * to TCL_OO_METHOD_VERSION_(1|CURRENT) in
* declarations. */
const char *name; /* Name of this type of method, mostly for
* debugging purposes. */
@@ -92,12 +94,31 @@ typedef struct {
* be copied directly. */
} Tcl_MethodType;
+typedef struct {
+ int version; /* Structure version field. Always to be equal
+ * to TCL_OO_METHOD_VERSION_2 in
+ * declarations. */
+ const char *name; /* Name of this type of method, mostly for
+ * debugging purposes. */
+ Tcl_MethodCallProc2 *callProc;
+ /* How to invoke this method. */
+ Tcl_MethodDeleteProc *deleteProc;
+ /* How to delete this method's type-specific
+ * data, or NULL if the type-specific data
+ * does not need deleting. */
+ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific
+ * data, or NULL if the type-specific data can
+ * be copied directly. */
+} Tcl_MethodType2;
+
/*
* The correct value for the version field of the Tcl_MethodType structure.
* This allows new versions of the structure to be introduced without breaking
* binary compatibility.
*/
+#define TCL_OO_METHOD_VERSION_1 1
+#define TCL_OO_METHOD_VERSION_2 2
#define TCL_OO_METHOD_VERSION_CURRENT 1
/*
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index d265c1a..a9ed6bf 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -369,7 +369,11 @@ TclOOInvokeContext(
* Run the method implementation.
*/
- return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ return (mPtr->typePtr->callProc)(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv);
+ }
+ return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 6ba5d14..13e07ec 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -123,6 +123,20 @@ TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object);
/* 31 */
TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp,
Tcl_Object object);
+/* 32 */
+TCLAPI int Tcl_MethodIsType2(Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr);
+/* 33 */
+TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType2 *typePtr,
+ void *clientData);
+/* 34 */
+TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType2 *typePtr,
+ void *clientData);
typedef struct {
const struct TclOOIntStubs *tclOOIntStubs;
@@ -164,6 +178,9 @@ typedef struct TclOOStubs {
int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */
Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */
+ int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */
+ Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */
+ Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */
} TclOOStubs;
extern const TclOOStubs *tclOOStubsPtr;
@@ -242,6 +259,12 @@ extern const TclOOStubs *tclOOStubsPtr;
(tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */
#define Tcl_GetObjectClassName \
(tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */
+#define Tcl_MethodIsType2 \
+ (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */
+#define Tcl_NewInstanceMethod2 \
+ (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */
+#define Tcl_NewMethod2 \
+ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */
#endif /* defined(USE_TCLOO_STUBS) */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 42c6637..686fd00 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2286,12 +2286,12 @@ TclOODefineSlots(
if (slotObject == NULL) {
continue;
}
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0,
&slotInfoPtr->getterType, NULL);
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0,
&slotInfoPtr->setterType, NULL);
if (slotInfoPtr->resolverType.callProc) {
- Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
+ TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0,
&slotInfoPtr->resolverType, NULL);
}
}
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 9488271..725c4ce 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -235,14 +235,14 @@ typedef struct Object {
* other spots). */
#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
* unknown method handler at that point. */
-#define HAS_PRIVATE_METHODS 0x20000
- /* Object/class has (or had) private methods,
- * and so shouldn't be cached so
- * aggressively. */
-#define DONT_DELETE 0x40000 /* Inhibit deletion of this object. Used
+#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. Used
* during fundamental object type mutation to
* make sure that the object actually survives
* to the end of the operation. */
+#define HAS_PRIVATE_METHODS 0x40000
+ /* Object/class has (or had) private methods,
+ * and so shouldn't be cached so
+ * aggressively. */
/*
* And the definition of a class. Note that every class also has an associated
@@ -492,6 +492,17 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp,
Object *useThisObj);
+MODULE_SCOPE int TclMethodIsType(Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr);
+MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp,
+ Tcl_Object object, Tcl_Obj *nameObj,
+ int flags, const Tcl_MethodType *typePtr,
+ void *clientData);
+MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls,
+ Tcl_Obj *nameObj, int flags,
+ const Tcl_MethodType *typePtr,
+ void *clientData);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, int objc,
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index ae1f3bd..73368e4 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -126,7 +126,7 @@ static const Tcl_MethodType fwdMethodType = {
*/
Tcl_Method
-Tcl_NewInstanceMethod(
+TclNewInstanceMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
@@ -187,6 +187,50 @@ Tcl_NewInstanceMethod(
oPtr->epoch++;
return (Tcl_Method) mPtr;
}
+Tcl_Method
+Tcl_NewInstanceMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
+Tcl_Method
+Tcl_NewInstanceMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Object object, /* The object that has the method attached to
+ * it. */
+ Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
+ * up to caller to manage storage (e.g., when
+ * it is a constructor or destructor). */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2");
+ }
+ return TclNewInstanceMethod(NULL, object, nameObj, flags,
+ (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -199,7 +243,7 @@ Tcl_NewInstanceMethod(
*/
Tcl_Method
-Tcl_NewMethod(
+TclNewMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
@@ -255,6 +299,48 @@ Tcl_NewMethod(
return (Tcl_Method) mPtr;
}
+
+Tcl_Method
+Tcl_NewMethod(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData);
+}
+
+Tcl_Method
+Tcl_NewMethod2(
+ TCL_UNUSED(Tcl_Interp *),
+ Tcl_Class cls, /* The class to attach the method to. */
+ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
+ * for constructors or destructors); if so, up
+ * to caller to manage storage. */
+ int flags, /* Whether this is a public method. */
+ const Tcl_MethodType2 *typePtr,
+ /* The type of method this is, which defines
+ * how to invoke, delete and clone the
+ * method. */
+ void *clientData) /* Some data associated with the particular
+ * method to be created. */
+{
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2");
+ }
+ return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData);
+}
/*
* ----------------------------------------------------------------------
@@ -304,7 +390,7 @@ TclOONewBasicMethod(
Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1);
Tcl_IncrRefCount(namePtr);
- Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr,
+ TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr,
(dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
Tcl_DecrRefCount(namePtr);
}
@@ -529,7 +615,7 @@ TclOOMakeProcInstanceMethod(
}
}
- return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
+ return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags,
typePtr, clientData);
}
@@ -642,7 +728,7 @@ TclOOMakeProcMethod(
}
}
- return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
+ return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr,
clientData);
}
@@ -1402,7 +1488,7 @@ TclOONewForwardInstanceMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
+ return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
@@ -1441,7 +1527,7 @@ TclOONewForwardMethod(
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
- return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
+ return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
@@ -1672,6 +1758,23 @@ Tcl_MethodName(
}
int
+TclMethodIsType(
+ Tcl_Method method,
+ const Tcl_MethodType *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (mPtr->typePtr == typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsType(
Tcl_Method method,
const Tcl_MethodType *typePtr,
@@ -1679,6 +1782,9 @@ Tcl_MethodIsType(
{
Method *mPtr = (Method *) method;
+ if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType");
+ }
if (mPtr->typePtr == typePtr) {
if (clientDataPtr != NULL) {
*clientDataPtr = mPtr->clientData;
@@ -1689,6 +1795,26 @@ Tcl_MethodIsType(
}
int
+Tcl_MethodIsType2(
+ Tcl_Method method,
+ const Tcl_MethodType2 *typePtr,
+ void **clientDataPtr)
+{
+ Method *mPtr = (Method *) method;
+
+ if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
+ Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2");
+ }
+ if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) {
+ if (clientDataPtr != NULL) {
+ *clientDataPtr = mPtr->clientData;
+ }
+ return 1;
+ }
+ return 0;
+}
+
+int
Tcl_MethodIsPublic(
Tcl_Method method)
{
diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c
index b9034f0..7b653cb 100644
--- a/generic/tclOOStubInit.c
+++ b/generic/tclOOStubInit.c
@@ -76,6 +76,9 @@ const TclOOStubs tclOOStubs = {
Tcl_MethodIsPrivate, /* 29 */
Tcl_GetClassOfObject, /* 30 */
Tcl_GetObjectClassName, /* 31 */
+ Tcl_MethodIsType2, /* 32 */
+ Tcl_NewInstanceMethod2, /* 33 */
+ Tcl_NewMethod2, /* 34 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 17635e7..e6b1372 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1587,12 +1587,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 {
@@ -1932,6 +1935,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.
*/
@@ -1940,7 +1944,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;
}
@@ -2155,6 +2161,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 cda840d..3b40f96 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
/*
@@ -1273,7 +1272,6 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
goto endgame;
-
}
p++;
len--;
@@ -1746,7 +1744,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. */
/*
@@ -1754,18 +1753,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) {
@@ -1865,7 +1871,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. */
/*
@@ -1873,19 +1880,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/tclStringObj.c b/generic/tclStringObj.c
index 86b3937..7ce1cdc 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -68,6 +68,9 @@ static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, int numChars);
static int UnicodeLength(const Tcl_UniChar *unicode);
+#if !defined(TCL_NO_DEPRECATED)
+static int UTF16Length(const unsigned short *unicode);
+#endif
static void UpdateStringOfString(Tcl_Obj *objPtr);
#if (TCL_UTF_MAX) > 3 && !defined(TCL_NO_DEPRECATED)
static void DupUTF16StringInternalRep(Tcl_Obj *objPtr,
@@ -562,6 +565,10 @@ Tcl_NewUnicodeObj(
TclNewObj(objPtr);
TclInvalidateStringRep(objPtr);
+ if (numChars < 0) {
+ numChars = UTF16Length(unicode);
+ }
+
String *stringPtr = (String *)ckalloc((offsetof(String, unicode)
+ sizeof(unsigned short)) + numChars * sizeof(unsigned short));
memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short));
@@ -974,6 +981,7 @@ Tcl_GetUnicodeFromObj(
}
#endif
+#if !defined(TCL_NO_DEPRECATED)
unsigned short *
TclGetUnicodeFromObj(
Tcl_Obj *objPtr, /* The object to find the unicode string
@@ -984,7 +992,11 @@ TclGetUnicodeFromObj(
{
String *stringPtr;
+#if TCL_UTF_MAX > 3
+ SetUTF16StringFromAny(NULL, objPtr);
+#else
SetStringFromAny(NULL, objPtr);
+#endif
stringPtr = GET_STRING(objPtr);
if (lengthPtr != NULL) {
@@ -992,6 +1004,7 @@ TclGetUnicodeFromObj(
}
return stringPtr->unicode;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -1451,14 +1464,7 @@ Tcl_SetUnicodeObj(
String *stringPtr;
if (numChars < 0) {
- numChars = 0;
-
- if (unicode) {
- while (numChars >= 0 && unicode[numChars] != 0) {
- numChars++;
- }
- }
- stringCheckLimits(numChars);
+ numChars = UTF16Length(unicode);
}
/*
@@ -1479,6 +1485,21 @@ Tcl_SetUnicodeObj(
TclInvalidateStringRep(objPtr);
stringPtr->allocated = numChars;
}
+
+static int
+UTF16Length(
+ const unsigned short *ucs2Ptr)
+{
+ int numChars = 0;
+
+ if (ucs2Ptr) {
+ while (numChars >= 0 && ucs2Ptr[numChars] != 0) {
+ numChars++;
+ }
+ }
+ stringCheckLimits(numChars);
+ return numChars;
+}
#endif
static int
@@ -1723,7 +1744,7 @@ Tcl_AppendUnicodeToObj(
return;
}
- SetStringFromAny(NULL, objPtr);
+ SetUTF16StringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length);
memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 0052682..4941348 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -96,6 +96,7 @@ static void uniCodePanic(void) {
}
# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic
# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic
+# define TclGetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, size_t *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 5d65b36..3db70fc 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -222,6 +222,7 @@ static Tcl_ObjCmdProc2 TestbytestringObjCmd;
static Tcl_ObjCmdProc2 TestsetbytearraylengthObjCmd;
static Tcl_ObjCmdProc2 TestpurebytesobjObjCmd;
static Tcl_ObjCmdProc2 TeststringbytesObjCmd;
+static Tcl_ObjCmdProc Testutf16stringObjCmd;
static Tcl_CmdProc TestcmdinfoCmd;
static Tcl_CmdProc TestcmdtokenCmd;
static Tcl_CmdProc TestcmdtraceCmd;
@@ -341,6 +342,7 @@ static Tcl_ObjCmdProc2 TestInterpResolverCmd;
#if defined(HAVE_CPUID) && !defined(MAC_OSX_TCL)
static Tcl_ObjCmdProc2 TestcpuidCmd;
#endif
+static Tcl_ObjCmdProc TestApplyLambdaObjCmd;
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -560,6 +562,7 @@ Tcltest_Init(
Tcl_CreateObjCommand2(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand2(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand2(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand2(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL);
Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand2(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -713,6 +716,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand2(interp, "testsetencpath", TestsetencpathObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd,
+ NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -1114,10 +1119,6 @@ TestcmdinfoCmd(
info.clientData = (void *) "new_command_data";
info.objProc = NULL;
info.objClientData = NULL;
-#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED)
- info.objProc2 = NULL;
- info.objClientData2 = NULL;
-#endif
info.deleteProc = CmdDelProc2;
info.deleteData = (void *) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
@@ -5185,6 +5186,43 @@ TestbytestringObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Testutf16stringObjCmd --
+ *
+ * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj
+ * C functions which broke in Tcl 8.7 and were undetected by the
+ * existing test suite. Bug [b79df322a9]
+ *
+ * Results:
+ * Returns the TCL_OK result code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+Testutf16stringObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ size_t objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ const unsigned short *p;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
+ }
+
+ p = Tcl_GetUnicode(objv[1]);
+ Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, -1));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetCmd --
*
* Implements the "testset{err,noerr}" cmds that are used when testing
@@ -8091,7 +8129,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
@@ -8101,3 +8217,4 @@ TestInterpResolverCmd(
* indent-tabs-mode: nil
* End:
*/
+
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 82adf65..87216c2 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -495,8 +495,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.
@@ -591,8 +590,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.