summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/AddErrInfo.318
-rw-r--r--doc/SetResult.35
-rw-r--r--generic/tclBinary.c4
-rw-r--r--generic/tclCompile.h2
-rw-r--r--generic/tclDisassemble.c135
-rw-r--r--generic/tclEnsemble.c377
-rw-r--r--generic/tclExecute.c8
-rw-r--r--generic/tclIndexObj.c52
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h28
-rw-r--r--generic/tclIntDecls.h4
-rw-r--r--generic/tclLiteral.c10
-rw-r--r--generic/tclNamesp.c19
-rw-r--r--generic/tclObj.c2
-rw-r--r--generic/tclProc.c14
-rw-r--r--generic/tclStringObj.c96
-rw-r--r--generic/tclStringRep.h28
-rw-r--r--generic/tclTestObj.c10
-rw-r--r--library/tcltest/tcltest.tcl2
-rw-r--r--tests/compile.test99
-rw-r--r--tests/for.test38
-rw-r--r--tests/indexObj.test5
-rw-r--r--tests/namespace.test55
23 files changed, 658 insertions, 355 deletions
diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3
index 0b59349..7d208c4 100644
--- a/doc/AddErrInfo.3
+++ b/doc/AddErrInfo.3
@@ -9,7 +9,7 @@
.so man.macros
.BS
.SH NAME
-Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
+Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -24,8 +24,6 @@ int
.sp
\fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR)
.sp
-\fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR)
-.sp
\fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR)
.sp
\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *) NULL\fR)
@@ -52,11 +50,6 @@ A dictionary of return options.
.AP char *message in
For \fBTcl_AddErrorInfo\fR,
this is a conventional C string to append to the \fB\-errorinfo\fR return option.
-For \fBTcl_AddObjErrorInfo\fR,
-this points to the first byte of an array of \fIlength\fR bytes
-containing a string to append to the \fB\-errorinfo\fR return option.
-This byte array may contain embedded null bytes
-unless \fIlength\fR is negative.
.AP Tcl_Obj *objPtr in
A message to be appended to the \fB\-errorinfo\fR return option
in the form of a Tcl_Obj value.
@@ -222,15 +215,6 @@ same functionality as \fBTcl_AddErrorInfo\fR. \fBTcl_AppendObjToErrorInfo\fR
is called when the string value to be appended to the \fB\-errorinfo\fR option
is available as a \fBTcl_Obj\fR instead of as a \fBchar\fR array.
.PP
-\fBTcl_AddObjErrorInfo\fR is nearly identical
-to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR
-argument. This allows the \fImessage\fR string to contain
-embedded null bytes. This is essentially never a good idea.
-If the \fImessage\fR needs to contain the null character \fBU+0000\fR,
-Tcl's usual internal encoding rules should be used to avoid
-the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR
-interface is used at all, it should be with a negative \fIlength\fR value.
-.PP
The procedure \fBTcl_SetObjErrorCode\fR is used to set the
\fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR
built up by the caller.
diff --git a/doc/SetResult.3 b/doc/SetResult.3
index 1d744d8..693ddcf 100644
--- a/doc/SetResult.3
+++ b/doc/SetResult.3
@@ -131,8 +131,7 @@ pointing to an unshared value representing an empty string.
If the result is a dynamically allocated string, its memory is free*d
and the result is left as a empty string.
\fBTcl_ResetResult\fR also clears the error state managed by
-\fBTcl_AddErrorInfo\fR, \fBTcl_AddObjErrorInfo\fR,
-and \fBTcl_SetErrorCode\fR.
+\fBTcl_AddErrorInfo\fR and \fBTcl_SetErrorCode\fR.
.PP
\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
It takes each of its \fIresult\fR arguments and appends them in order
@@ -164,7 +163,7 @@ The source interpreter will have its result reset by this operation.
.SH "DEPRECATED INTERFACES"
.SS "OLD STRING PROCEDURES"
.PP
-Use of the following procedures (is deprecated
+Use of the following procedures is deprecated
since they manipulate the Tcl result as a string.
Procedures such as \fBTcl_SetObjResult\fR
that manipulate the result as a value
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index b9460f2..bd78e89 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -648,7 +648,7 @@ TclAppendBytesToByteArray(
}
byteArrayPtr = GET_BYTEARRAY(objPtr);
- if (len > INT_MAX - byteArrayPtr->used) {
+ if (len + byteArrayPtr->used > UINT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
@@ -685,7 +685,7 @@ TclAppendBytesToByteArray(
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
- if (bytes && (len > 0) && (len != (size_t)-1)) {
+ if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
}
byteArrayPtr->used += len;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index db3e764..bb4da2a 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1096,7 +1096,7 @@ MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes,
- int length, unsigned int hash, int *newPtr,
+ size_t length, unsigned int hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index c85fe13..1d616fb 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -6,7 +6,7 @@
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
- * Copyright (c) 2013 Donal K. Fellows.
+ * Copyright (c) 2013-2016 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -1279,9 +1279,11 @@ Tcl_DisassembleObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const types[] = {
+ "constructor", "destructor",
"lambda", "method", "objmethod", "proc", "script", NULL
};
enum Types {
+ DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR,
DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC,
DISAS_SCRIPT
};
@@ -1290,6 +1292,7 @@ Tcl_DisassembleObjCmd(
Proc *procPtr = NULL;
Tcl_HashEntry *hPtr;
Object *oPtr;
+ Method *methodPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "type ...");
@@ -1384,6 +1387,136 @@ Tcl_DisassembleObjCmd(
codeObjPtr = objv[2];
break;
+ case DISAS_CLASS_CONSTRUCTOR:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the body of a constructor.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ methodPtr = oPtr->classPtr->constructorPtr;
+ if (methodPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" has no defined constructor",
+ TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "CONSRUCTOR", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(methodPtr);
+ if (procPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of constructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "METHODTYPE", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compile if necessary.
+ */
+
+ if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ Command cmd;
+
+ /*
+ * Yes, this is ugly, but we need to pass the namespace in to the
+ * compiler in two places.
+ */
+
+ cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+ procPtr->cmdPtr = &cmd;
+ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
+ (Namespace *) oPtr->namespacePtr, "body of constructor",
+ TclGetString(objv[2]));
+ procPtr->cmdPtr = NULL;
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ codeObjPtr = procPtr->bodyPtr;
+ break;
+
+ case DISAS_CLASS_DESTRUCTOR:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "className");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the body of a destructor.
+ */
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+ TclGetString(objv[2]), NULL);
+ return TCL_ERROR;
+ }
+
+ methodPtr = oPtr->classPtr->destructorPtr;
+ if (methodPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" has no defined destructor",
+ TclGetString(objv[2])));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "DESRUCTOR", NULL);
+ return TCL_ERROR;
+ }
+ procPtr = TclOOGetProcFromMethod(methodPtr);
+ if (procPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "body not available for this kind of destructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+ "METHODTYPE", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compile if necessary.
+ */
+
+ if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
+ Command cmd;
+
+ /*
+ * Yes, this is ugly, but we need to pass the namespace in to the
+ * compiler in two places.
+ */
+
+ cmd.nsPtr = (Namespace *) oPtr->namespacePtr;
+ procPtr->cmdPtr = &cmd;
+ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
+ (Namespace *) oPtr->namespacePtr, "body of destructor",
+ TclGetString(objv[2]));
+ procPtr->cmdPtr = NULL;
+ if (result != TCL_OK) {
+ return result;
+ }
+ }
+ codeObjPtr = procPtr->bodyPtr;
+ break;
+
case DISAS_CLASS_METHOD:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "className methodName");
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 75be2f9..808a50f 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -30,11 +30,10 @@ static int NsEnsembleStringOrder(const void *strPtr1,
const void *strPtr2);
static void DeleteEnsembleConfig(ClientData clientData);
static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
- EnsembleConfig *ensemblePtr,
- const char *subcmdName, Tcl_Obj *prefixObjPtr);
+ EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
+ Tcl_Obj *fix);
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
-static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void CompileToInvokedCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
Command *cmdPtr, CompileEnv *envPtr);
@@ -42,6 +41,9 @@ static int CompileBasicNArgCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr);
+static Tcl_NRPostProc FreeObj;
+static Tcl_NRPostProc FreeER;
+
/*
* The lists of subcommands and options for the [namespace ensemble] command.
*/
@@ -77,14 +79,30 @@ enum EnsConfigOpts {
* that implements it.
*/
-const Tcl_ObjType tclEnsembleCmdType = {
+static const Tcl_ObjType ensembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
- StringOfEnsembleCmdRep, /* updateStringProc */
+ NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
+/*
+ * The internal rep for caching ensemble subcommand lookups and
+ * spell corrections.
+ */
+
+typedef struct {
+ int epoch; /* Used to confirm when the data in this
+ * really structure matches up with the
+ * ensemble. */
+ Tcl_Command token; /* Reference to the comamnd for which this
+ * structure is a cache of the resolution. */
+ Tcl_Obj *fix; /* Corrected spelling, if needed. */
+ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand
+ * hash table. */
+} EnsembleCmdRep;
+
static inline Tcl_Obj *
NewNsObj(
@@ -1643,6 +1661,8 @@ NsEnsembleImplementationCmdNR(
* names. */
int reparseCount = 0; /* Number of reparses. */
Tcl_Obj *errorObj; /* Used for building error messages. */
+ Tcl_Obj *subObj;
+ int subIdx;
/*
* Must recheck objc, since numParameters might have changed. Cf. test
@@ -1650,24 +1670,18 @@ NsEnsembleImplementationCmdNR(
*/
restartEnsembleParse:
- if (objc < 2 + ensemblePtr->numParameters) {
+ subIdx = 1 + ensemblePtr->numParameters;
+ if (objc < subIdx + 1) {
/*
* We don't have a subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
- Tcl_Obj **elemPtrs; /* Parameter names */
- int len; /* Number of parameters to append */
Tcl_DStringInit(&buf);
- if (ensemblePtr->parameterList == NULL) {
- len = 0;
- } else if (TclListObjGetElements(NULL, ensemblePtr->parameterList,
- &len, &elemPtrs) != TCL_OK) {
- Tcl_Panic("List of ensemble parameters is not a list");
- }
- for (; len>0; len--,elemPtrs++) {
- TclDStringAppendObj(&buf, *elemPtrs);
+ if (ensemblePtr->parameterList) {
+ Tcl_DStringAppend(&buf,
+ TclGetString(ensemblePtr->parameterList), -1);
TclDStringAppendLiteral(&buf, " ");
}
TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
@@ -1695,6 +1709,8 @@ NsEnsembleImplementationCmdNR(
* up in there and go straight to dispatch.
*/
+ subObj = objv[subIdx];
+
if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
/*
* Table of subcommands is still valid; therefore there might be a
@@ -1703,15 +1719,16 @@ NsEnsembleImplementationCmdNR(
* part where we do the invocation of the subcommand.
*/
- if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
- EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
- ->internalRep.twoPtrValue.ptr1;
+ if (subObj->typePtr==&ensembleCmdType){
+ EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
- if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
- ensembleCmd->epoch == ensemblePtr->epoch &&
+ if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == ensemblePtr->token) {
- prefixObj = ensembleCmd->realPrefixObj;
+ prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
+ if (ensembleCmd->fix) {
+ TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
+ }
goto runResultingSubcommand;
}
}
@@ -1726,18 +1743,14 @@ NsEnsembleImplementationCmdNR(
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
- TclGetString(objv[1 + ensemblePtr->numParameters]));
+ TclGetString(subObj));
if (hPtr != NULL) {
- char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
-
- prefixObj = Tcl_GetHashValue(hPtr);
/*
* Cache for later in the subcommand object.
*/
- MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
- ensemblePtr, fullName, prefixObj);
+ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
* Could not map, no prefixing, go to unknown/error handling.
@@ -1757,9 +1770,9 @@ NsEnsembleImplementationCmdNR(
char *fullName = NULL; /* Full name of the subcommand. */
int stringLength, i;
int tableLength = ensemblePtr->subcommandTable.numEntries;
+ Tcl_Obj *fix;
- subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]);
- stringLength = objv[1 + ensemblePtr->numParameters]->length;
+ subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
register int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
@@ -1799,16 +1812,22 @@ NsEnsembleImplementationCmdNR(
Tcl_Panic("full name %s not found in supposedly synchronized hash",
fullName);
}
- prefixObj = Tcl_GetHashValue(hPtr);
+
+ /*
+ * Record the spelling correction for usage message.
+ */
+
+ fix = Tcl_NewStringObj(fullName, -1);
/*
* Cache for later in the subcommand object.
*/
- MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
- ensemblePtr, fullName, prefixObj);
+ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
+ TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
+ prefixObj = Tcl_GetHashValue(hPtr);
Tcl_IncrRefCount(prefixObj);
runResultingSubcommand:
@@ -1827,45 +1846,26 @@ NsEnsembleImplementationCmdNR(
*/
{
- Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the
- * target command prefix. */
Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
* Will be freed by the dispatch engine. */
- int prefixObjc, copyObjc;
+ int prefixObjc;
- /*
- * Get the prefix that we're rewriting to. To do this we need to
- * ensure that the internal representation of the list does not change
- * so that we can safely keep the internal representations of the
- * elements in the list.
- *
- * TODO: Use conventional list operations to make this code sane!
- */
+ Tcl_ListObjLength(NULL, prefixObj, &prefixObjc);
- TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
-
- copyObjc = objc - 2 + prefixObjc;
- copyPtr = Tcl_NewListObj(copyObjc, NULL);
- if (copyObjc > 0) {
- register Tcl_Obj **copyObjv;
- /* Space used to construct the list of
- * arguments to pass to the command that
- * implements the ensemble subcommand. */
- register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
- register int i;
-
- listRepPtr->elemCount = copyObjc;
- copyObjv = &listRepPtr->elements;
- memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
- memcpy(copyObjv+prefixObjc, objv+1,
- sizeof(Tcl_Obj *) * ensemblePtr->numParameters);
- memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters,
- objv+ensemblePtr->numParameters+2,
- sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2));
-
- for (i=0; i < copyObjc; i++) {
- Tcl_IncrRefCount(copyObjv[i]);
- }
+ if (objc == 2) {
+ copyPtr = prefixObj;
+ Tcl_IncrRefCount(copyPtr);
+ TclNRAddCallback(interp, FreeObj, copyPtr, NULL, NULL, NULL);
+ } else {
+ int copyObjc = objc - 2 + prefixObjc;
+
+ copyPtr = Tcl_NewListObj(copyObjc, NULL);
+ Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ ensemblePtr->numParameters, objv+1);
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ objc - 2 - ensemblePtr->numParameters,
+ objv + 2 + ensemblePtr->numParameters);
}
TclDecrRefCount(prefixObj);
@@ -1918,20 +1918,17 @@ NsEnsembleImplementationCmdNR(
Tcl_ResetResult(interp);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
+ TclGetString(subObj), NULL);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown subcommand \"%s\": namespace %s does not"
- " export any commands",
- TclGetString(objv[1+ensemblePtr->numParameters]),
+ " export any commands", TclGetString(subObj),
ensemblePtr->nsPtr->fullName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
return TCL_ERROR;
}
errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
- TclGetString(objv[1+ensemblePtr->numParameters]));
+ TclGetString(subObj));
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
@@ -2038,6 +2035,161 @@ TclResetRewriteEnsemble(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclSpellFix --
+ *
+ * Record a spelling correction that needs making in the
+ * generation of the WrongNumArgs usage message.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Can create an alternative ensemble rewrite structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FreeER(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **tmp = (Tcl_Obj **)data[0];
+
+ ckfree(tmp[2]);
+ ckfree(tmp);
+ return result;
+}
+
+static int
+FreeObj(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *objPtr = (Tcl_Obj *)data[0];
+
+ Tcl_DecrRefCount(objPtr);
+ return result;
+}
+
+void
+TclSpellFix(
+ Tcl_Interp *interp,
+ Tcl_Obj *const *objv,
+ int objc,
+ int badIdx,
+ Tcl_Obj *bad,
+ Tcl_Obj *fix)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *const *search;
+ Tcl_Obj **store;
+ int idx;
+ int size;
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 0;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+ }
+
+ /* Compute the valid length of the ensemble root */
+
+ size = iPtr->ensembleRewrite.numRemovedObjs + objc
+ - iPtr->ensembleRewrite.numInsertedObjs;
+
+ search = iPtr->ensembleRewrite.sourceObjs;
+ if (search[0] == NULL) {
+ /* Awful casting abuse here */
+ search = (Tcl_Obj *const *) search[1];
+ }
+
+ if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
+ /*
+ * Misspelled value was inserted. We cannot directly jump
+ * to the bad value, but have to search.
+ */
+ idx = 1;
+ while (idx < size) {
+ if (search[idx] == bad) {
+ break;
+ }
+ idx++;
+ }
+ if (idx == size) {
+ return;
+ }
+ } else {
+ /* Jump to the misspelled value. */
+ idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx
+ - iPtr->ensembleRewrite.numInsertedObjs;
+
+ /* Verify */
+ if (search[idx] != bad) {
+ Tcl_Panic("SpellFix: programming error");
+ }
+ }
+
+ search = iPtr->ensembleRewrite.sourceObjs;
+ if (search[0] == NULL) {
+ store = (Tcl_Obj **)search[2];
+ } else {
+ Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
+ tmp[0] = NULL;
+ tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs;
+ tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *));
+ memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *));
+
+ iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
+ TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL);
+ store = (Tcl_Obj **)tmp[2];
+ }
+
+ store[idx] = fix;
+ Tcl_IncrRefCount(fix);
+ TclNRAddCallback(interp, FreeObj, fix, NULL, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFetchEnsembleRoot --
+ *
+ * Returns the root of ensemble rewriting, if any.
+ * If no root exists, returns objv instead.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *const *
+TclFetchEnsembleRoot(
+ Tcl_Interp *interp,
+ Tcl_Obj *const *objv,
+ int objc,
+ int *objcPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->ensembleRewrite.sourceObjs) {
+ *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ return iPtr->ensembleRewrite.sourceObjs;
+ }
+ *objcPtr = objc;
+ return objv;
+}
+
+/*
* ----------------------------------------------------------------------
*
* EnsmebleUnknownCallback --
@@ -2202,17 +2354,16 @@ static void
MakeCachedEnsembleCommand(
Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
- const char *subcommandName,
- Tcl_Obj *prefixObjPtr)
+ Tcl_HashEntry *hPtr,
+ Tcl_Obj *fix)
{
register EnsembleCmdRep *ensembleCmd;
- int length;
- if (objPtr->typePtr == &tclEnsembleCmdType) {
+ if (objPtr->typePtr == &ensembleCmdType) {
ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
- TclNsDecrRefCount(ensembleCmd->nsPtr);
- ckfree(ensembleCmd->fullSubcmdName);
+ if (ensembleCmd->fix) {
+ Tcl_DecrRefCount(ensembleCmd->fix);
+ }
} else {
/*
* Kill the old internal rep, and replace it with a brand new one of
@@ -2222,22 +2373,20 @@ MakeCachedEnsembleCommand(
TclFreeIntRep(objPtr);
ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
- objPtr->typePtr = &tclEnsembleCmdType;
+ objPtr->typePtr = &ensembleCmdType;
}
/*
* Populate the internal rep.
*/
- ensembleCmd->nsPtr = ensemblePtr->nsPtr;
ensembleCmd->epoch = ensemblePtr->epoch;
ensembleCmd->token = ensemblePtr->token;
- ensemblePtr->nsPtr->refCount++;
- ensembleCmd->realPrefixObj = prefixObjPtr;
- length = strlen(subcommandName)+1;
- ensembleCmd->fullSubcmdName = ckalloc(length);
- memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
- Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
+ if (fix) {
+ Tcl_IncrRefCount(fix);
+ }
+ ensembleCmd->fix = fix;
+ ensembleCmd->hPtr = hPtr;
}
/*
@@ -2618,9 +2767,9 @@ FreeEnsembleCmdRep(
{
EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
- ckfree(ensembleCmd->fullSubcmdName);
- TclNsDecrRefCount(ensembleCmd->nsPtr);
+ if (ensembleCmd->fix) {
+ Tcl_DecrRefCount(ensembleCmd->fix);
+ }
ckfree(ensembleCmd);
objPtr->typePtr = NULL;
}
@@ -2650,48 +2799,16 @@ DupEnsembleCmdRep(
{
EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
- int length = strlen(ensembleCmd->fullSubcmdName);
- copyPtr->typePtr = &tclEnsembleCmdType;
+ copyPtr->typePtr = &ensembleCmdType;
copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
- ensembleCopy->nsPtr = ensembleCmd->nsPtr;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
- ensembleCopy->nsPtr->refCount++;
- ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
- Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
- ensembleCopy->fullSubcmdName = ckalloc(length + 1);
- memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
- (unsigned) length+1);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * StringOfEnsembleCmdRep --
- *
- * Creates a string representation of a Tcl_Obj that holds a subcommand
- * of an ensemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object gains a string (UTF-8) representation.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-StringOfEnsembleCmdRep(
- Tcl_Obj *objPtr)
-{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
- int length = strlen(ensembleCmd->fullSubcmdName);
-
- objPtr->length = length;
- objPtr->bytes = ckalloc(length + 1);
- memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
+ ensembleCopy->fix = ensembleCmd->fix;
+ if (ensembleCopy->fix) {
+ Tcl_IncrRefCount(ensembleCopy->fix);
+ }
+ ensembleCopy->hPtr = ensembleCmd->hPtr;
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 8e3c33b..9016ff4 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2017,8 +2017,6 @@ TclNRExecuteByteCode(
* Push the callback for bytecode execution
*/
- TclResetRewriteEnsemble(interp, 1);
-
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
/* cleanup */ INT2PTR(0), NULL);
return TCL_OK;
@@ -5290,9 +5288,9 @@ TEBCresume(
s1len = Tcl_GetCharLength(valuePtr);
s2len = Tcl_GetCharLength(value2Ptr);
- if ((s1len == valuePtr->length)
+ if (((size_t)s1len == valuePtr->length)
&& (valuePtr->bytes != NULL)
- && (s2len == value2Ptr->length)
+ && ((size_t)s2len == value2Ptr->length)
&& (value2Ptr->bytes != NULL)) {
s1 = valuePtr->bytes;
s2 = value2Ptr->bytes;
@@ -5461,7 +5459,7 @@ TEBCresume(
} else if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1);
- } else if (valuePtr->bytes && length == valuePtr->length) {
+ } else if (valuePtr->bytes && (size_t)length == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index b80d649..288e38a 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -820,29 +820,6 @@ Tcl_WrongNumArgs(
Interp *iPtr = (Interp *) interp;
const char *elementStr;
- /*
- * [incr Tcl] does something fairly horrific when generating error
- * messages for its ensembles; it passes the whole set of ensemble
- * arguments as a list in the first argument. This means that this code
- * causes a problem in iTcl if it attempts to correctly quote all
- * arguments, which would be the correct thing to do. We work around this
- * nasty behaviour for now, and hope that we can remove it all in the
- * future...
- */
-
-#ifndef AVOID_HACKS_FOR_ITCL
- int isFirst = 1; /* Special flag used to inhibit the treating
- * of the first word as a list element so the
- * hacky way Itcl generates error messages for
- * its ensembles will still work. [Bug
- * 1066837] */
-# define MAY_QUOTE_WORD (!isFirst)
-# define AFTER_FIRST_WORD (isFirst = 0)
-#else /* !AVOID_HACKS_FOR_ITCL */
-# define MAY_QUOTE_WORD 1
-# define AFTER_FIRST_WORD (void) 0
-#endif /* AVOID_HACKS_FOR_ITCL */
-
TclNewObj(objPtr);
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
@@ -863,6 +840,14 @@ Tcl_WrongNumArgs(
Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;
/*
+ * Check for spelling fixes, and substitute the fixed values.
+ */
+
+ if (origObjv[0] == NULL) {
+ origObjv = (Tcl_Obj *const *)origObjv[2];
+ }
+
+ /*
* We only know how to do rewriting if all the replaced objects are
* actually arguments (in objv) to this function. Otherwise it just
* gets too complicated and we'd be better off just giving a slightly
@@ -895,19 +880,13 @@ Tcl_WrongNumArgs(
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
- } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
- register EnsembleCmdRep *ecrPtr =
- origObjv[i]->internalRep.twoPtrValue.ptr1;
-
- elementStr = ecrPtr->fullSubcmdName;
- elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
- if (MAY_QUOTE_WORD && len != elemLen) {
+ if (len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp,
(unsigned)len + 1);
@@ -919,8 +898,6 @@ Tcl_WrongNumArgs(
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
- AFTER_FIRST_WORD;
-
/*
* Add a space if the word is not the last one (which has a
* moderately complex condition here).
@@ -949,11 +926,6 @@ Tcl_WrongNumArgs(
register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
- } else if (objv[i]->typePtr == &tclEnsembleCmdType) {
- register EnsembleCmdRep *ecrPtr =
- objv[i]->internalRep.twoPtrValue.ptr1;
-
- Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
@@ -963,7 +935,7 @@ Tcl_WrongNumArgs(
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
- if (MAY_QUOTE_WORD && len != elemLen) {
+ if (len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp,
(unsigned) len + 1);
@@ -976,8 +948,6 @@ Tcl_WrongNumArgs(
}
}
- AFTER_FIRST_WORD;
-
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
@@ -1000,8 +970,6 @@ Tcl_WrongNumArgs(
Tcl_AppendStringsToObj(objPtr, "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
Tcl_SetObjResult(interp, objPtr);
-#undef MAY_QUOTE_WORD
-#undef AFTER_FIRST_WORD
}
/*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 23efd99..bf62525 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1024,7 +1024,7 @@ declare 250 {
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
- char *bytes, int length, int flags)
+ char *bytes, size_t length, int flags)
}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 34dd3ef..4d494e3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -390,27 +390,6 @@ struct NamespacePathEntry {
#define TCL_FIND_ONLY_NS 0x1000
/*
- * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in
- * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs
- * referring to the same subcommand, even where one is a duplicate of another.
- */
-
-typedef struct {
- Namespace *nsPtr; /* The namespace backing the ensemble which
- * this is a subcommand of. */
- int epoch; /* Used to confirm when the data in this
- * really structure matches up with the
- * ensemble. */
- Tcl_Command token; /* Reference to the comamnd for which this
- * structure is a cache of the resolution. */
- char *fullSubcmdName; /* The full (local) name of the subcommand,
- * allocated with ckalloc(). */
- Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the
- * command that implements this ensemble
- * subcommand. */
-} EnsembleCmdRep;
-
-/*
* The client data for an ensemble command. This consists of the table of
* commands that are actually exported by the namespace, and an epoch counter
* that, combined with the exportLookupEpoch field of the namespace structure,
@@ -2864,6 +2843,8 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr);
MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
+MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp,
+ Tcl_Obj *const *objv, int objc, int *objcPtr);
MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
MODULE_SCOPE void TclFinalizeAsync(void);
MODULE_SCOPE void TclFinalizeDoubleConversion(void);
@@ -3063,6 +3044,9 @@ MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue, Tcl_Encoding encoding);
MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
+MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
+ Tcl_Obj *const *objv, int objc, int subIdx,
+ Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
@@ -4329,7 +4313,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclNumUtfChars(numChars, bytes, numBytes) \
do { \
- int count, i = (numBytes); \
+ size_t count, i = (numBytes); \
unsigned char *str = (unsigned char *) (bytes); \
while (i && (*str < 0xC0)) { i--; str++; } \
count = (numBytes) - i; \
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 7705156..4d09d55 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -548,7 +548,7 @@ TCLAPI void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
int force);
/* 251 */
TCLAPI int TclRegisterLiteral(void *envPtr, char *bytes,
- int length, int flags);
+ size_t length, int flags);
typedef struct TclIntStubs {
int magic;
@@ -805,7 +805,7 @@ typedef struct TclIntStubs {
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
- int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
+ int (*tclRegisterLiteral) (void *envPtr, char *bytes, size_t length, int flags); /* 251 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 03200ca..a258ffc 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -176,7 +176,7 @@ TclCreateLiteral(
Interp *iPtr,
char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
- int length, /* Number of bytes in the string. */
+ size_t length, /* Number of bytes in the string. */
unsigned hash, /* The string's hash. If -1, it will be
* computed here. */
int *newPtr,
@@ -245,7 +245,7 @@ TclCreateLiteral(
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
- "TclRegisterLiteral", (length>60? 60 : length), bytes);
+ "TclRegisterLiteral", (length>60? 60 : (int)length), bytes);
}
#endif
@@ -363,7 +363,7 @@ TclRegisterLiteral(
register char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
- int length, /* Number of bytes in the string. If < 0, the
+ size_t length, /* Number of bytes in the string. If -1, the
* string consists of all bytes up to the
* first null character. */
int flags) /* If LITERAL_ON_HEAP then the caller already
@@ -381,7 +381,7 @@ TclRegisterLiteral(
int localHash, objIndex, new;
Namespace *nsPtr;
- if (length < 0) {
+ if (length == (size_t)-1) {
length = (bytes ? strlen(bytes) : 0);
}
hash = HashString(bytes, length);
@@ -397,7 +397,7 @@ TclRegisterLiteral(
objPtr = localPtr->objPtr;
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
- && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
+ && (memcmp(objPtr->bytes, bytes, length) == 0)))) {
if (flags & LITERAL_ON_HEAP) {
ckfree(bytes);
}
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index cd70c86..982712f 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -3354,14 +3354,7 @@ NRNamespaceEvalCmd(
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
- if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- framePtr->objc = objc;
- framePtr->objv = objv;
- } else {
- framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- - iPtr->ensembleRewrite.numInsertedObjs;
- framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
- }
+ framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc);
if (objc == 3) {
/*
@@ -3768,7 +3761,6 @@ NRNamespaceInscopeCmd(
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
- register Interp *iPtr = (Interp *) interp;
int i;
Tcl_Obj *cmdObjPtr;
@@ -3794,14 +3786,7 @@ NRNamespaceInscopeCmd(
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
- if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- framePtr->objc = objc;
- framePtr->objv = objv;
- } else {
- framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- - iPtr->ensembleRewrite.numInsertedObjs;
- framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
- }
+ framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc);
/*
* Execute the command. If there is just one argument, just treat it as a
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 4e7a208..93f6fb7 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1527,7 +1527,7 @@ int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
- return (objPtr->length == -1);
+ return (objPtr->length == (size_t)-1);
}
/*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index b663caf..9c4fd1d 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1087,13 +1087,7 @@ ProcWrongNumArgs(
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
- ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1;
-
-#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = framePtr->objv[skip-1];
-#else
- desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv);
-#endif /* AVOID_HACKS_FOR_ITCL */
}
Tcl_IncrRefCount(desiredObjs[0]);
@@ -1527,6 +1521,10 @@ InitArgsAndLocals(
*/
incorrectArgs:
+ if ((skip != 1) &&
+ TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
memset(varPtr, 0,
((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
return ProcWrongNumArgs(interp, skip);
@@ -2716,10 +2714,6 @@ TclNRApplyObjCmd(
extraPtr->efi.fields[0].clientData = lambdaPtr;
extraPtr->cmd.clientData = &extraPtr->efi;
- if (TclInitRewriteEnsemble(interp, 1, 0, objv)) {
- TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
- }
-
result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
if (result == TCL_OK) {
TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 9b72d52..57f368a 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -45,27 +45,27 @@
static void AppendPrintfToObjVA(Tcl_Obj *objPtr,
const char *format, va_list argList);
static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int appendNumChars);
+ const Tcl_UniChar *unicode, size_t appendNumChars);
static void AppendUnicodeToUtfRep(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+ const Tcl_UniChar *unicode, size_t numChars);
static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr,
- const char *bytes, int numBytes);
+ const char *bytes, size_t numBytes);
static void AppendUtfToUtfRep(Tcl_Obj *objPtr,
- const char *bytes, int numBytes);
+ const char *bytes, size_t numBytes);
static void DupStringInternalRep(Tcl_Obj *objPtr,
Tcl_Obj *copyPtr);
static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+ const Tcl_UniChar *unicode, size_t numChars);
static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
- const char *bytes, int numBytes,
- int numAppendChars);
+ const char *bytes, size_t numBytes,
+ size_t numAppendChars);
static void FillUnicodeRep(Tcl_Obj *objPtr);
static void FreeStringInternalRep(Tcl_Obj *objPtr);
-static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag);
-static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed);
+static void GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag);
+static void GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed);
static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void SetUnicodeObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, int numChars);
+ const Tcl_UniChar *unicode, size_t numChars);
static size_t UnicodeLength(const Tcl_UniChar *unicode);
static void UpdateStringOfString(Tcl_Obj *objPtr);
@@ -122,7 +122,7 @@ const Tcl_ObjType tclStringType = {
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
- int needed,
+ size_t needed,
int flag)
{
/*
@@ -134,14 +134,14 @@ GrowStringBuffer(
String *stringPtr = GET_STRING(objPtr);
char *ptr = NULL;
- int attempt;
+ size_t attempt;
if (objPtr->bytes == tclEmptyStringRep) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
attempt = 2 * needed;
- if (attempt >= 0) {
+ if ((int)attempt >= 0) {
ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
}
if (ptr == NULL) {
@@ -150,9 +150,9 @@ GrowStringBuffer(
* overflow into invalid argument values for attempt.
*/
- unsigned int limit = INT_MAX - needed;
- unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
- int growth = (int) ((extra > limit) ? limit : extra);
+ size_t limit = INT_MAX - needed;
+ size_t extra = needed - objPtr->length + TCL_MIN_GROWTH;
+ size_t growth = (extra > limit) ? limit : extra;
attempt = needed + growth;
ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
@@ -173,7 +173,7 @@ GrowStringBuffer(
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
- int needed)
+ size_t needed)
{
/*
* Pre-conditions:
@@ -183,7 +183,7 @@ GrowUnicodeBuffer(
*/
String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
- int attempt;
+ size_t attempt;
if (stringPtr->maxChars > 0) {
/*
@@ -191,7 +191,7 @@ GrowUnicodeBuffer(
*/
attempt = 2 * needed;
- if ((size_t)attempt <= STRING_MAXCHARS) {
+ if (attempt <= STRING_MAXCHARS) {
ptr = stringAttemptRealloc(stringPtr, attempt);
}
if (ptr == NULL) {
@@ -200,10 +200,10 @@ GrowUnicodeBuffer(
* overflow into invalid argument values for attempt.
*/
- unsigned int limit = STRING_MAXCHARS - needed;
- unsigned int extra = needed - stringPtr->numChars
+ size_t limit = STRING_MAXCHARS - needed;
+ size_t extra = needed - stringPtr->numChars
+ TCL_MIN_UNICHAR_GROWTH;
- int growth = (int) ((extra > limit) ? limit : extra);
+ size_t growth = (extra > limit) ? limit : extra;
attempt = needed + growth;
ptr = stringAttemptRealloc(stringPtr, attempt);
@@ -489,7 +489,7 @@ Tcl_GetUniChar(
* If numChars is unknown, compute it.
*/
- if (stringPtr->numChars == -1) {
+ if (stringPtr->numChars == (size_t)-1) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
@@ -623,7 +623,7 @@ Tcl_GetRange(
* If numChars is unknown, compute it.
*/
- if (stringPtr->numChars == -1) {
+ if (stringPtr->numChars == (size_t)-1) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
@@ -969,12 +969,12 @@ SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* object. */
- int numChars) /* Number of characters in the unicode
+ size_t numChars) /* Number of characters in the unicode
* string. */
{
String *stringPtr;
- if (numChars < 0) {
+ if (numChars == (size_t)-1) {
numChars = UnicodeLength(unicode);
}
@@ -1050,7 +1050,7 @@ Tcl_AppendLimitedToObj(
ellipsis = "...";
}
toCopy = (bytes == NULL) ? limit
- : Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes;
+ : (size_t)(Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes);
}
/*
@@ -1315,12 +1315,12 @@ static void
AppendUnicodeToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to append. */
- int appendNumChars) /* Number of chars of "unicode" to append. */
+ size_t appendNumChars) /* Number of chars of "unicode" to append. */
{
String *stringPtr;
- int numChars;
+ size_t numChars;
- if (appendNumChars < 0) {
+ if (appendNumChars == (size_t)-1) {
appendNumChars = UnicodeLength(unicode);
}
if (appendNumChars == 0) {
@@ -1342,7 +1342,7 @@ AppendUnicodeToUnicodeRep(
stringCheckLimits(numChars);
if (numChars > stringPtr->maxChars) {
- int offset = -1;
+ size_t offset = (size_t)-1;
/*
* Protect against case where unicode points into the existing
@@ -1362,7 +1362,7 @@ AppendUnicodeToUnicodeRep(
* Relocate unicode if needed; see above.
*/
- if (offset >= 0) {
+ if (offset != (size_t)-1) {
unicode = stringPtr->unicode + offset;
}
}
@@ -1404,13 +1404,13 @@ static void
AppendUnicodeToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to convert to UTF. */
- int numChars) /* Number of chars of "unicode" to convert. */
+ size_t numChars) /* Number of chars of "unicode" to convert. */
{
String *stringPtr = GET_STRING(objPtr);
numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
- if (stringPtr->numChars != -1) {
+ if (stringPtr->numChars != (size_t)-1) {
stringPtr->numChars += numChars;
}
}
@@ -1437,7 +1437,7 @@ static void
AppendUtfToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to convert to Unicode. */
- int numBytes) /* Number of bytes of "bytes" to convert. */
+ size_t numBytes) /* Number of bytes of "bytes" to convert. */
{
String *stringPtr;
@@ -1473,10 +1473,10 @@ static void
AppendUtfToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to append. */
- int numBytes) /* Number of bytes of "bytes" to append. */
+ size_t numBytes) /* Number of bytes of "bytes" to append. */
{
String *stringPtr;
- int newLength, oldLength;
+ size_t newLength, oldLength;
if (numBytes == 0) {
return;
@@ -1492,7 +1492,7 @@ AppendUtfToUtfRep(
}
oldLength = objPtr->length;
newLength = numBytes + oldLength;
- if (newLength < 0) {
+ if ((int)newLength < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
@@ -2769,17 +2769,17 @@ static void
ExtendUnicodeRepWithString(
Tcl_Obj *objPtr,
const char *bytes,
- int numBytes,
- int numAppendChars)
+ size_t numBytes,
+ size_t numAppendChars)
{
String *stringPtr = GET_STRING(objPtr);
- int needed, numOrigChars = 0;
+ size_t needed, numOrigChars = 0;
Tcl_UniChar *dst;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
- if (numAppendChars == -1) {
+ if (numAppendChars == (size_t)-1) {
TclNumUtfChars(numAppendChars, bytes, numBytes);
}
needed = numOrigChars + numAppendChars;
@@ -2830,7 +2830,7 @@ DupStringInternalRep(
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
- if (srcStringPtr->numChars == -1) {
+ if (srcStringPtr->numChars == (size_t)-1) {
/*
* The String struct in the source value holds zero useful data. Don't
* bother copying it. Don't even bother allocating space in which to
@@ -2960,17 +2960,17 @@ static int
ExtendStringRepWithUnicode(
Tcl_Obj *objPtr,
const Tcl_UniChar *unicode,
- int numChars)
+ size_t numChars)
{
/*
* Pre-condition: this is the "string" Tcl_ObjType.
*/
- int i, origLength, size = 0;
+ size_t i, origLength, size = 0;
char *dst;
String *stringPtr = GET_STRING(objPtr);
- if (numChars < 0) {
+ if (numChars == (size_t)-1) {
numChars = UnicodeLength(unicode);
}
@@ -2987,7 +2987,7 @@ ExtendStringRepWithUnicode(
* Quick cheap check in case we have more than enough room.
*/
- if (numChars <= (INT_MAX - size)/TCL_UTF_MAX
+ if (numChars <= (size_t)((INT_MAX - size)/TCL_UTF_MAX)
&& stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
goto copyBytes;
}
@@ -2995,7 +2995,7 @@ ExtendStringRepWithUnicode(
for (i = 0; i < numChars && size >= 0; i++) {
size += TclUtfCount(unicode[i]);
}
- if (size < 0) {
+ if ((int)size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index a11f25a..66d4578 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -47,15 +47,15 @@
*/
typedef struct {
- int numChars; /* The number of chars in the string. -1 means
- * this value has not been calculated. >= 0
+ size_t numChars; /* The number of chars in the string. (size_t)-1 means
+ * this value has not been calculated. Any other
* means that there is a valid Unicode rep, or
* that the number of UTF bytes == the number
* of chars. */
- int allocated; /* The amount of space actually allocated for
+ size_t allocated; /* The amount of space actually allocated for
* the UTF string (minus 1 byte for the
* termination char). */
- int maxChars; /* Max number of chars that can fit in the
+ size_t maxChars; /* Max number of chars that can fit in the
* space allocated for the unicode array. */
int hasUnicode; /* Boolean determining whether the string has
* a Unicode representation. */
@@ -65,24 +65,24 @@ typedef struct {
} String;
#define STRING_MAXCHARS \
- (((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar))
+ ((UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar))
#define STRING_SIZE(numChars) \
(sizeof(String) + ((numChars) * sizeof(Tcl_UniChar)))
#define stringCheckLimits(numChars) \
- do { \
- if ((size_t)(numChars) > STRING_MAXCHARS) { \
- Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
- (int)STRING_MAXCHARS); \
- } \
+ do { \
+ if ((size_t)(numChars) > STRING_MAXCHARS) { \
+ Tcl_Panic("max length for a Tcl unicode value (%" TCL_LL_MODIFIER "d chars) exceeded", \
+ (Tcl_WideInt)STRING_MAXCHARS); \
+ } \
} while (0)
#define stringAttemptAlloc(numChars) \
- (String *) attemptckalloc(STRING_SIZE(numChars) )
+ (String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
- (String *) ckalloc(STRING_SIZE(numChars) )
+ (String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
- (String *) ckrealloc((ptr), STRING_SIZE(numChars) )
+ (String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
- (String *) attemptckrealloc((ptr), STRING_SIZE(numChars) )
+ (String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index bdf20f8..d96f41a 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -19,6 +19,7 @@
#endif
#include "tclInt.h"
#include "tommath.h"
+#include "tclStringRep.h"
/*
@@ -46,13 +47,6 @@ static int TestobjCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-
-typedef struct {
- int numChars;
- int allocated;
- int maxChars;
- Tcl_UniChar unicode[2];
-} TestString;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
@@ -1142,7 +1136,7 @@ TeststringobjCmd(
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
- TestString *strPtr;
+ String *strPtr;
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 2e83952..75975d2 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -2709,7 +2709,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
DebugPuts 1 "No test directories remain after applying match\
and skip patterns!"
}
- return $matchDirs
+ return [lsort $matchDirs]
}
# tcltest::runAllTests --
diff --git a/tests/compile.test b/tests/compile.test
index 2b9ea51..c76bd82 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -678,7 +678,7 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup
# change without warning.
set disassemblables [linsert [join {
- lambda method objmethod proc script
+ constructor destructor lambda method objmethod proc script
} ", "] end-1 or]
test compile-18.1 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble
@@ -872,6 +872,103 @@ test compile-18.39 {disassembler - basics} -setup {
} -cleanup {
foo destroy
} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.40 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble constructor
+} -match glob -result {wrong # args: should be "* constructor className"}
+test compile-18.41 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble constructor nosuchclass
+} -result {nosuchclass does not refer to an object}
+test compile-18.42 {disassembler - basics} -returnCodes error -setup {
+ oo::object create justanobject
+} -body {
+ tcl::unsupported::disassemble constructor justanobject
+} -cleanup {
+ justanobject destroy
+} -result {"justanobject" is not a class}
+test compile-18.43 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::disassemble constructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined constructor}
+test compile-18.44 {disassembler - basics} -setup {
+ oo::class create foo {constructor {} {set x 1}}
+} -body {
+ # Allow any string: the result format is not defined anywhere!
+ tcl::unsupported::disassemble constructor foo
+} -cleanup {
+ foo destroy
+} -match glob -result *
+test compile-18.45 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode constructor
+} -match glob -result {wrong # args: should be "* constructor className"}
+test compile-18.46 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode constructor nosuchobject
+} -result {nosuchobject does not refer to an object}
+test compile-18.47 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::getbytecode constructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined constructor}
+test compile-18.48 {disassembler - basics} -setup {
+ oo::class create foo {constructor {} {set x 1}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode constructor foo]
+} -cleanup {
+ foo destroy
+} -result "$bytecodekeys"
+# There is no compile-18.49
+test compile-18.50 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble destructor
+} -match glob -result {wrong # args: should be "* destructor className"}
+test compile-18.51 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::disassemble destructor nosuchclass
+} -result {nosuchclass does not refer to an object}
+test compile-18.52 {disassembler - basics} -returnCodes error -setup {
+ oo::object create justanobject
+} -body {
+ tcl::unsupported::disassemble destructor justanobject
+} -cleanup {
+ justanobject destroy
+} -result {"justanobject" is not a class}
+test compile-18.53 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::disassemble destructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined destructor}
+test compile-18.54 {disassembler - basics} -setup {
+ oo::class create foo {destructor {set x 1}}
+} -body {
+ # Allow any string: the result format is not defined anywhere!
+ tcl::unsupported::disassemble destructor foo
+} -cleanup {
+ foo destroy
+} -match glob -result *
+test compile-18.55 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode destructor
+} -match glob -result {wrong # args: should be "* destructor className"}
+test compile-18.56 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode destructor nosuchobject
+} -result {nosuchobject does not refer to an object}
+test compile-18.57 {disassembler - basics} -returnCodes error -setup {
+ oo::class create constructorless
+} -body {
+ tcl::unsupported::getbytecode destructor constructorless
+} -cleanup {
+ constructorless destroy
+} -result {"constructorless" has no defined destructor}
+test compile-18.58 {disassembler - basics} -setup {
+ oo::class create foo {destructor {set x 1}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode destructor foo]
+} -cleanup {
+ foo destroy
+} -result "$bytecodekeys"
test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
# This will panic in a --enable-symbols=compile build, unless bug is fixed.
diff --git a/tests/for.test b/tests/for.test
index 8e701d6..c8a8187 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -451,7 +451,7 @@ proc formatMail {} {
set c [string length $line]
}
}
- set newline [string range $line 0 $c]
+ set newline [string trimright [string range $line 0 $c]]
if {! $continuation} {
append result $newline $NL
} else {
@@ -507,7 +507,7 @@ releases of the Tcl scripting language and the Tk toolk
it. The first beta versions of these
releases were released on August 30, 1996. These releas
es contain only minor changes,
-so we hope to have only a single beta release and to
+so we hope to have only a single beta release and to
go final in early October, 1996.
@@ -519,34 +519,34 @@ and changes files in the distributions for more complet
e information on what has
changed, including both feature changes and bug fixes.
- There are new options to the file command for
+ There are new options to the file command for
copying files (file copy),
- deleting files and directories (file delete),
+ deleting files and directories (file delete),
creating directories (file
mkdir), and renaming files (file rename).
The implementation of exec has been improved great
ly for Windows 95 and
Windows NT.
- There is a new memory allocator for the Macintosh
+ There is a new memory allocator for the Macintosh
version, which should be
more efficient than the old one.
- Tk's grid geometry manager has been completely
+ Tk's grid geometry manager has been completely
rewritten. The layout
algorithm produces much better layouts than before
, especially where rows or
columns were stretchable.
- There are new commands for creating common dialog
+ There are new commands for creating common dialog
boxes:
tk_chooseColor, tk_getOpenFile, tk_getSaveFile and
- tk_messageBox. These use native dialog boxes if
+ tk_messageBox. These use native dialog boxes if
they are available.
There is a new virtual event mechanism for handlin
g events in a more portable
- way. See the new command event. It also allows
+ way. See the new command event. It also allows
events (both physical and
virtual) to be generated dynamically.
-Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl
+Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl
7.5 and Tk 4.1 except for
changes in the C APIs for custom channel drivers. Scrip
ts written for earlier releases
@@ -556,27 +556,27 @@ Obtaining The Releases
Binary Releases
-Pre-compiled releases are available for the following
+Pre-compiled releases are available for the following
platforms:
Windows 3.1, Windows 95, and Windows NT: Fetch
- ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
+ ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then
execute it. The file is a
- self-extracting executable. It will install the
+ self-extracting executable. It will install the
Tcl and Tk libraries, the wish and
tclsh programs, and documentation.
Macintosh (both 68K and PowerPC): Fetch
- ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx.
+ ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx.
The file is in binhex format,
- which is understood by Fetch, StuffIt, and many
+ which is understood by Fetch, StuffIt, and many
other Mac utilities. The
- unpacked file is a self-installing executable:
+ unpacked file is a self-installing executable:
double-click on it and it will create a
- folder containing all that you need to run Tcl
+ folder containing all that you need to run Tcl
and Tk.
- UNIX (Solaris 2.* and SunOS, other systems
+ UNIX (Solaris 2.* and SunOS, other systems
soon to follow). Easy to install
- binary packages are now for sale at the Sun Labs
+ binary packages are now for sale at the Sun Labs
Tcl/Tk Shop. Check it out!
}
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 646cb02..f4d3dc6 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -107,11 +107,6 @@ test indexObj-5.5 {Tcl_WrongNumArgs} testindexobj {
test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj {
testwrongnumargs 2 "" mycmd foo
} "wrong # args: should be \"mycmd foo\""
-# Contrast this with test proc-3.6; they have to be like this because
-# of [Bug 1066837] so Itcl won't break.
-test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj {
- testwrongnumargs 2 "fee fi" "fo fum" foo bar
-} "wrong # args: should be \"fo fum foo fee fi\""
test indexObj-6.1 {Tcl_GetIndexFromObjStruct} testindexobj {
set x a
diff --git a/tests/namespace.test b/tests/namespace.test
index fc74d73..2a5f308 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -2107,6 +2107,61 @@ test namespace-50.4 {chained ensembles affect error messages} -body {
rename a {}
rename c {}
}
+test namespace-50.5 {[4402cfa58c]} -setup {
+ proc bar {ev} {}
+ proc bingo {xx} {}
+ namespace ensemble create -command launch -map {foo bar event bingo}
+ set result {}
+} -body {
+ catch {launch foo} m; lappend result $m
+ catch {launch ev} m; lappend result $m
+ catch {launch foo} m; lappend result $m
+} -cleanup {
+ rename launch {}
+ rename bingo {}
+ rename bar {}
+} -result {{wrong # args: should be "launch foo ev"} {wrong # args: should be "launch event xx"} {wrong # args: should be "launch foo ev"}}
+test namespace-50.6 {[4402cfa58c]} -setup {
+ proc target {x y} {}
+ namespace ensemble create -command e2 -map {s2 target}
+ namespace ensemble create -command e1 -map {s1 e2}
+ set result {}
+} -body {
+ set s s
+ catch {e1 s1 s2 a} m; lappend result $m
+ catch {e1 $s s2 a} m; lappend result $m
+ catch {e1 s1 $s a} m; lappend result $m
+ catch {e1 $s $s a} m; lappend result $m
+} -cleanup {
+ rename e1 {}
+ rename e2 {}
+ rename target {}
+} -result {{wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"}}
+test namespace-50.7 {[4402cfa58c]} -setup {
+ proc target {x y} {}
+ namespace ensemble create -command e2 -map {s2 target}
+ namespace ensemble create -command e1 -map {s1 e2} -parameters foo
+ set result {}
+} -body {
+ set s s
+ catch {e1 s2 s1 a} m; lappend result $m
+ catch {e1 $s s1 a} m; lappend result $m
+ catch {e1 s2 $s a} m; lappend result $m
+ catch {e1 $s $s a} m; lappend result $m
+} -cleanup {
+ rename e1 {}
+ rename e2 {}
+ rename target {}
+} -result {{wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"}}
+test namespace-50.8 {[f961d7d1dd]} -setup {
+ proc target {} {}
+ namespace ensemble create -command e -map {s target} -parameters {{a b}}
+} -body {
+ e
+} -returnCodes error -result {wrong # args: should be "e {a b} subcommand ?arg ...?"} -cleanup {
+ rename e {}
+ rename target {}
+}
test namespace-51.1 {name resolution path control} -body {
namespace eval ::test_ns_1 {
generated by cgit v0.12 at 2025-03-29 10:02:29 (GMT)