summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c12
-rw-r--r--generic/tclBasic.c23
-rw-r--r--generic/tclBinary.c74
-rw-r--r--generic/tclCmdMZ.c47
-rw-r--r--generic/tclCompCmdsGR.c25
-rw-r--r--generic/tclCompCmdsSZ.c364
-rw-r--r--generic/tclCompile.c33
-rw-r--r--generic/tclCompile.h46
-rw-r--r--generic/tclDisassemble.c11
-rw-r--r--generic/tclExecute.c256
-rw-r--r--generic/tclIO.c296
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclOO.c3
-rw-r--r--generic/tclOOBasic.c20
-rw-r--r--generic/tclStringObj.c42
-rw-r--r--generic/tclStringTrim.h27
-rw-r--r--tests/coroutine.test92
-rwxr-xr-xunix/configure2
-rw-r--r--unix/tcl.m42
-rw-r--r--unix/tclUnixInit.c29
-rw-r--r--win/makefile.vc2
-rw-r--r--win/tclWinInit.c18
22 files changed, 1095 insertions, 338 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 89c286a..d1866c8 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -26,6 +26,7 @@
*- jumpTable testing
*- syntax (?)
*- returnCodeBranch
+ *- tclooNext, tclooNextClass
*/
#include "tclInt.h"
@@ -49,7 +50,7 @@ typedef enum BasicBlockCatchState {
BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */
BBCS_NONE, /* Block is outside of any catch */
BBCS_INCATCH, /* Block is within a catch context */
- BBCS_CAUGHT, /* Block is within a catch context and
+ BBCS_CAUGHT /* Block is within a catch context and
* may be executed after an exception fires */
} BasicBlockCatchState;
@@ -120,7 +121,7 @@ enum BasicBlockFlags {
* marking it as the start of a 'catch'
* sequence. The 'jumpTarget' is the exception
* exit from the catch block. */
- BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction,
+ BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction,
* unwinding the catch from the exception
* stack. */
};
@@ -183,7 +184,7 @@ typedef enum TalInstType {
* produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand
* (INCR_STK_IMM) */
- ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by
+ ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by
* LVT entry. Fixed arity */
} TalInstType;
@@ -437,6 +438,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
{"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
{"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1},
+ {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1},
{"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1},
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
@@ -477,6 +479,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
{"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1},
{"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
+ {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
@@ -516,7 +519,8 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_RESOLVE_COMMAND, /* 154 */
INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
INST_CONCAT_STK, /* 169 */
- INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */
+ INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */
+ INST_NUM_TYPE /* 180 */
};
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0442446..795fe15 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = {
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE},
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE},
{"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE},
- {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE},
+ {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
@@ -8418,8 +8418,7 @@ TclNRYieldToObjCmd(
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
Tcl_Obj *listPtr, *nsObjPtr;
- Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- Tcl_Namespace *ns1Ptr;
+ Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8433,11 +8432,13 @@ TclNRYieldToObjCmd(
return TCL_ERROR;
}
- /*
- * Add the tailcall in the caller env, then just yield.
- *
- * This is essentially code from TclNRTailcallObjCmd
- */
+ if (((Namespace *) nsPtr)->flags & NS_DYING) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto called in deleted namespace", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+ NULL);
+ return TCL_ERROR;
+ }
/*
* Add the tailcall in the caller env, then just yield.
@@ -8446,15 +8447,9 @@ TclNRYieldToObjCmd(
*/
listPtr = Tcl_NewListObj(objc, objv);
-
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
- if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
- || (nsPtr != ns1Ptr)) {
- Tcl_Panic("yieldto failed to find the proper namespace");
- }
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
-
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 4e977f2..981f174 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -610,9 +610,7 @@ UpdateStringOfByteArray(
*
* This function appends an array of bytes to a byte array object. Note
* that the object *must* be unshared, and the array of bytes *must not*
- * refer to the object being appended to. Also the caller must have
- * already checked that the final length of the bytearray after the
- * append operations is complete will not overflow the int range.
+ * refer to the object being appended to.
*
* Results:
* None.
@@ -631,6 +629,7 @@ TclAppendBytesToByteArray(
int len)
{
ByteArray *byteArrayPtr;
+ int needed;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
@@ -639,64 +638,57 @@ TclAppendBytesToByteArray(
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
+ if (len == 0) {
+ /* Append zero bytes is a no-op. */
+ return;
+ }
if (objPtr->typePtr != &tclByteArrayType) {
SetByteArrayFromAny(NULL, objPtr);
}
byteArrayPtr = GET_BYTEARRAY(objPtr);
+ if (len > INT_MAX - byteArrayPtr->used) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ needed = byteArrayPtr->used + len;
/*
* If we need to, resize the allocated space in the byte array.
*/
- if (byteArrayPtr->used + len > byteArrayPtr->allocated) {
- unsigned int attempt, used = byteArrayPtr->used;
- ByteArray *tmpByteArrayPtr = NULL;
+ if (needed > byteArrayPtr->allocated) {
+ ByteArray *ptr = NULL;
+ int attempt;
- attempt = byteArrayPtr->allocated;
- if (attempt < 1) {
- /*
- * No allocated bytes, so must be none used too. We use this
- * method to calculate how many bytes to allocate because we can
- * end up with a zero-length buffer otherwise, when doubling can
- * cause trouble. [Bug 3067036]
- */
-
- attempt = len + 1;
- } else {
- do {
- attempt *= 2;
- } while (attempt < used+len);
+ if (needed <= INT_MAX/2) {
+ /* Try to allocate double the total space that is needed. */
+ attempt = 2 * needed;
+ ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
+ if (ptr == NULL) {
+ /* Try to allocate double the increment that is needed (plus). */
+ unsigned int limit = INT_MAX - needed;
+ unsigned int extra = len + TCL_MIN_GROWTH;
+ int growth = (int) ((extra > limit) ? limit : extra);
- if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) {
- tmpByteArrayPtr = attemptckrealloc(byteArrayPtr,
- BYTEARRAY_SIZE(attempt));
+ attempt = needed + growth;
+ ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
-
- if (tmpByteArrayPtr == NULL) {
- attempt = used + len;
- if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) {
- Tcl_Panic("attempt to allocate a bigger buffer than we can handle");
- }
- tmpByteArrayPtr = ckrealloc(byteArrayPtr,
- BYTEARRAY_SIZE(attempt));
+ if (ptr == NULL) {
+ /* Last chance: Try to allocate exactly what is needed. */
+ attempt = needed;
+ ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
-
- byteArrayPtr = tmpByteArrayPtr;
+ byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
- byteArrayPtr->used = used;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
- /*
- * Do the append if there's any point.
- */
-
- if (len > 0) {
+ if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
- byteArrayPtr->used += len;
- TclInvalidateStringRep(objPtr);
}
+ byteArrayPtr->used += len;
+ TclInvalidateStringRep(objPtr);
}
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d477216..00c9f2f 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -32,6 +32,39 @@ static int TryPostHandler(ClientData data[], Tcl_Interp *interp,
int result);
static int UniCharIsAscii(int character);
static int UniCharIsHexDigit(int character);
+
+/*
+ * Default set of characters to trim in [string trim] and friends. This is a
+ * UTF-8 literal string containing all Unicode space characters [TIP #413]
+ */
+
+const char tclDefaultTrimSet[] =
+ "\x09\x0a\x0b\x0c\x0d " /* ASCII */
+ "\xc0\x80" /* nul (U+0000) */
+ "\xc2\x85" /* next line (U+0085) */
+ "\xc2\xa0" /* non-breaking space (U+00a0) */
+ "\xe1\x9a\x80" /* ogham space mark (U+1680) */
+ "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */
+ "\xe2\x80\x80" /* en quad (U+2000) */
+ "\xe2\x80\x81" /* em quad (U+2001) */
+ "\xe2\x80\x82" /* en space (U+2002) */
+ "\xe2\x80\x83" /* em space (U+2003) */
+ "\xe2\x80\x84" /* three-per-em space (U+2004) */
+ "\xe2\x80\x85" /* four-per-em space (U+2005) */
+ "\xe2\x80\x86" /* six-per-em space (U+2006) */
+ "\xe2\x80\x87" /* figure space (U+2007) */
+ "\xe2\x80\x88" /* punctuation space (U+2008) */
+ "\xe2\x80\x89" /* thin space (U+2009) */
+ "\xe2\x80\x8a" /* hair space (U+200a) */
+ "\xe2\x80\x8b" /* zero width space (U+200b) */
+ "\xe2\x80\xa8" /* line separator (U+2028) */
+ "\xe2\x80\xa9" /* paragraph separator (U+2029) */
+ "\xe2\x80\xaf" /* narrow no-break space (U+202f) */
+ "\xe2\x81\x9f" /* medium mathematical space (U+205f) */
+ "\xe2\x81\xa0" /* word joiner (U+2060) */
+ "\xe3\x80\x80" /* ideographic space (U+3000) */
+ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */
+;
/*
*----------------------------------------------------------------------
@@ -3158,8 +3191,8 @@ StringTrimCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = DEFAULT_TRIM_SET;
- length2 = strlen(DEFAULT_TRIM_SET);
+ string2 = tclDefaultTrimSet;
+ length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3206,8 +3239,8 @@ StringTrimLCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = DEFAULT_TRIM_SET;
- length2 = strlen(DEFAULT_TRIM_SET);
+ string2 = tclDefaultTrimSet;
+ length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3252,8 +3285,8 @@ StringTrimRCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = DEFAULT_TRIM_SET;
- length2 = strlen(DEFAULT_TRIM_SET);
+ string2 = tclDefaultTrimSet;
+ length2 = strlen(tclDefaultTrimSet);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3299,7 +3332,7 @@ TclInitStringCmd(
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
- {"is", StringIsCmd, NULL, NULL, NULL, 0},
+ {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0},
{"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index b8a7e0f..b3e273f 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -3075,6 +3075,31 @@ TclCompileObjectNextCmd(
}
int
+TclCompileObjectNextToCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ int i;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
+ return TCL_ERROR;
+ }
+
+ for (i=0 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileObjectSelfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 8e422c1..ece363b 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -429,6 +429,284 @@ TclCompileStringIndexCmd(
}
int
+TclCompileStringIsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ static const char *const isClasses[] = {
+ "alnum", "alpha", "ascii", "control",
+ "boolean", "digit", "double", "entier",
+ "false", "graph", "integer", "list",
+ "lower", "print", "punct", "space",
+ "true", "upper", "wideinteger", "wordchar",
+ "xdigit", NULL
+ };
+ enum isClasses {
+ STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
+ STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
+ STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
+ STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
+ STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
+ STR_IS_XDIGIT
+ };
+ int t, range, allowEmpty = 0, end;
+ InstStringClassType strClassType;
+ Tcl_Obj *isClass;
+
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
+ return TCL_ERROR;
+ }
+ isClass = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
+ Tcl_DecrRefCount(isClass);
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
+ &t) != TCL_OK) {
+ Tcl_DecrRefCount(isClass);
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
+ }
+ Tcl_DecrRefCount(isClass);
+
+#define GotLiteral(tokenPtr, word) \
+ ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \
+ (tokenPtr)[1].size > 1 && \
+ (tokenPtr)[1].start[0] == word[0] && \
+ strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
+
+ /*
+ * Cannot handle the -failindex option at all, and that's the only legal
+ * way to have more than 4 arguments.
+ */
+
+ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (parsePtr->numWords == 3) {
+ allowEmpty = 1;
+ } else {
+ if (!GotLiteral(tokenPtr, "-strict")) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+#undef GotLiteral
+
+ /*
+ * Compile the code. There are several main classes of check here.
+ * 1. Character classes
+ * 2. Booleans
+ * 3. Integers
+ * 4. Floats
+ * 5. Lists
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
+
+ switch ((enum isClasses) t) {
+ case STR_IS_ALNUM:
+ strClassType = STR_CLASS_ALNUM;
+ goto compileStrClass;
+ case STR_IS_ALPHA:
+ strClassType = STR_CLASS_ALPHA;
+ goto compileStrClass;
+ case STR_IS_ASCII:
+ strClassType = STR_CLASS_ASCII;
+ goto compileStrClass;
+ case STR_IS_CONTROL:
+ strClassType = STR_CLASS_CONTROL;
+ goto compileStrClass;
+ case STR_IS_DIGIT:
+ strClassType = STR_CLASS_DIGIT;
+ goto compileStrClass;
+ case STR_IS_GRAPH:
+ strClassType = STR_CLASS_GRAPH;
+ goto compileStrClass;
+ case STR_IS_LOWER:
+ strClassType = STR_CLASS_LOWER;
+ goto compileStrClass;
+ case STR_IS_PRINT:
+ strClassType = STR_CLASS_PRINT;
+ goto compileStrClass;
+ case STR_IS_PUNCT:
+ strClassType = STR_CLASS_PUNCT;
+ goto compileStrClass;
+ case STR_IS_SPACE:
+ strClassType = STR_CLASS_SPACE;
+ goto compileStrClass;
+ case STR_IS_UPPER:
+ strClassType = STR_CLASS_UPPER;
+ goto compileStrClass;
+ case STR_IS_WORD:
+ strClassType = STR_CLASS_WORD;
+ goto compileStrClass;
+ case STR_IS_XDIGIT:
+ strClassType = STR_CLASS_XDIGIT;
+ compileStrClass:
+ if (allowEmpty) {
+ OP1( STR_CLASS, strClassType);
+ } else {
+ int over, over2;
+
+ OP( DUP);
+ OP1( STR_CLASS, strClassType);
+ JUMP1( JUMP_TRUE, over);
+ OP( POP);
+ PUSH( "0");
+ JUMP1( JUMP, over2);
+ FIXJUMP1(over);
+ PUSH( "");
+ OP( STR_NEQ);
+ FIXJUMP1(over2);
+ }
+ return TCL_OK;
+
+ case STR_IS_BOOL:
+ case STR_IS_FALSE:
+ case STR_IS_TRUE:
+ OP( TRY_CVT_TO_BOOLEAN);
+ switch (t) {
+ int over, over2;
+
+ case STR_IS_BOOL:
+ if (allowEmpty) {
+ JUMP1( JUMP_TRUE, over);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP, over2);
+ FIXJUMP1(over);
+ OP( POP);
+ PUSH( "1");
+ FIXJUMP1(over2);
+ } else {
+ OP4( REVERSE, 2);
+ OP( POP);
+ }
+ return TCL_OK;
+ case STR_IS_TRUE:
+ JUMP1( JUMP_TRUE, over);
+ if (allowEmpty) {
+ PUSH( "");
+ OP( STR_EQ);
+ } else {
+ OP( POP);
+ PUSH( "0");
+ }
+ FIXJUMP1( over);
+ OP( LNOT);
+ OP( LNOT);
+ return TCL_OK;
+ case STR_IS_FALSE:
+ JUMP1( JUMP_TRUE, over);
+ if (allowEmpty) {
+ PUSH( "");
+ OP( STR_NEQ);
+ } else {
+ OP( POP);
+ PUSH( "1");
+ }
+ FIXJUMP1( over);
+ OP( LNOT);
+ return TCL_OK;
+ }
+
+ case STR_IS_DOUBLE: {
+ int satisfied, isEmpty;
+
+ if (allowEmpty) {
+ OP( DUP);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_TRUE, isEmpty);
+ OP( NUM_TYPE);
+ JUMP1( JUMP_TRUE, satisfied);
+ PUSH( "0");
+ JUMP1( JUMP, end);
+ FIXJUMP1( isEmpty);
+ OP( POP);
+ FIXJUMP1( satisfied);
+ } else {
+ OP( NUM_TYPE);
+ JUMP1( JUMP_TRUE, satisfied);
+ PUSH( "0");
+ JUMP1( JUMP, end);
+ TclAdjustStackDepth(-1, envPtr);
+ FIXJUMP1( satisfied);
+ }
+ PUSH( "1");
+ FIXJUMP1( end);
+ return TCL_OK;
+ }
+
+ case STR_IS_INT:
+ case STR_IS_WIDE:
+ case STR_IS_ENTIER:
+ if (allowEmpty) {
+ int testNumType;
+
+ OP( DUP);
+ OP( NUM_TYPE);
+ OP( DUP);
+ JUMP1( JUMP_TRUE, testNumType);
+ OP( POP);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP, end);
+ TclAdjustStackDepth(1, envPtr);
+ FIXJUMP1( testNumType);
+ OP4( REVERSE, 2);
+ OP( POP);
+ } else {
+ OP( NUM_TYPE);
+ OP( DUP);
+ JUMP1( JUMP_FALSE, end);
+ }
+
+ switch (t) {
+ case STR_IS_INT:
+ PUSH( "1");
+ OP( EQ);
+ break;
+ case STR_IS_WIDE:
+ PUSH( "2");
+ OP( LE);
+ break;
+ case STR_IS_ENTIER:
+ PUSH( "3");
+ OP( LE);
+ break;
+ }
+ FIXJUMP1( end);
+ return TCL_OK;
+
+ case STR_IS_LIST:
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ OP( DUP);
+ OP( LIST_LENGTH);
+ OP( POP);
+ ExceptionRangeEnds(envPtr, range);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( POP);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( LNOT);
+ return TCL_OK;
+ }
+
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
TclCompileStringMatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -814,7 +1092,7 @@ TclCompileStringTrimLCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
- PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM_LEFT);
return TCL_OK;
@@ -842,7 +1120,7 @@ TclCompileStringTrimRCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
- PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM_RIGHT);
return TCL_OK;
@@ -870,7 +1148,7 @@ TclCompileStringTrimCmd(
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
- PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM);
return TCL_OK;
@@ -943,6 +1221,41 @@ TclCompileStringToTitleCmd(
}
/*
+ * Support definitions for the [string is] compilation.
+ */
+
+static int
+UniCharIsAscii(
+ int character)
+{
+ return (character >= 0) && (character < 0x80);
+}
+
+static int
+UniCharIsHexDigit(
+ int character)
+{
+ return (character >= 0) && (character < 0x80) && isxdigit(character);
+}
+
+StringClassDesc const tclStringClassTable[] = {
+ {"alnum", Tcl_UniCharIsAlnum},
+ {"alpha", Tcl_UniCharIsAlpha},
+ {"ascii", UniCharIsAscii},
+ {"control", Tcl_UniCharIsControl},
+ {"digit", Tcl_UniCharIsDigit},
+ {"graph", Tcl_UniCharIsGraph},
+ {"lower", Tcl_UniCharIsLower},
+ {"print", Tcl_UniCharIsPrint},
+ {"punct", Tcl_UniCharIsPunct},
+ {"space", Tcl_UniCharIsSpace},
+ {"upper", Tcl_UniCharIsUpper},
+ {"word", Tcl_UniCharIsWordChar},
+ {"xdigit", UniCharIsHexDigit},
+ {NULL, NULL}
+};
+
+/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
@@ -3477,6 +3790,51 @@ TclCompileYieldCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileYieldToCmd --
+ *
+ * Procedure called to compile the "yieldto" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "yieldto" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldToCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ int i;
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ OP( NS_CURRENT);
+ for (i = 1 ; i < parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ OP4( LIST, i);
+ OP( YIELD_TO_INVOKE);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CompileUnaryOpCmd --
*
* Utility routine to compile the unary operator commands.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0d57b3b..eaa0f84 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -618,8 +618,37 @@ InstructionDesc const tclInstructionTable[] = {
* Stack: ... cmdName => ... fullOriginalCmdName */
{"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}},
- /* Push the identity of the current TclOO object (i.e., the name of
- * its current public access command) on the stack. */
+ /* Call the next item on the TclOO call chain, passing opnd arguments
+ * (min 1, max 255, *includes* "next"). The result of the invoked
+ * method implementation will be pushed on the stack in place of the
+ * arguments (similar to invokeStk).
+ * Stack: ... "next" arg2 arg3 -- argN => ... result */
+ {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Call the following item on the TclOO call chain defined by class
+ * className, passing opnd arguments (min 2, max 255, *includes*
+ * "nextto" and the class name). The result of the invoked method
+ * implementation will be pushed on the stack in place of the
+ * arguments (similar to invokeStk).
+ * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */
+
+ {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}},
+ /* Makes the current coroutine yield the value at the top of the
+ * stack, invoking the given command/args with resolution in the given
+ * namespace (all packed into a list), and places the list of values
+ * that are the response back on top of the stack when it resumes.
+ * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */
+
+ {"numericType", 1, 0, 0, {OPERAND_NONE}},
+ /* Pushes the numeric type code of the word at the top of the stack.
+ * Stack: ... value => ... typeCode */
+ {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}},
+ /* Try converting stktop to boolean if possible. No errors.
+ * Stack: ... value => ... value isStrictBool */
+ {"strclass", 2, 0, 1, {OPERAND_SCLS1}},
+ /* See if all the characters of the given string are a member of the
+ * specified (by opnd) character class. Note that an empty string will
+ * satisfy the class check (standard definition of "all").
+ * Stack: ... stringValue => ... boolean */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 525c87a..b4215f2 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -808,9 +808,16 @@ typedef struct ByteCode {
#define INST_ORIGIN_COMMAND 178
#define INST_TCLOO_NEXT 179
+#define INST_TCLOO_NEXT_CLASS 180
+
+#define INST_YIELD_TO_INVOKE 181
+
+#define INST_NUM_TYPE 182
+#define INST_TRY_CVT_TO_BOOLEAN 183
+#define INST_STR_CLASS 184
/* The last opcode */
-#define LAST_INST_OPCODE 179
+#define LAST_INST_OPCODE 184
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -841,8 +848,9 @@ typedef enum InstOperandType {
OPERAND_OFFSET4, /* Four byte signed jump offset. */
OPERAND_LIT1, /* One byte unsigned index into table of
* literals. */
- OPERAND_LIT4 /* Four byte unsigned index into table of
+ OPERAND_LIT4, /* Four byte unsigned index into table of
* literals. */
+ OPERAND_SCLS1 /* Index into tclStringClassTable. */
} InstOperandType;
typedef struct InstructionDesc {
@@ -861,6 +869,40 @@ typedef struct InstructionDesc {
MODULE_SCOPE InstructionDesc const tclInstructionTable[];
/*
+ * Constants used by INST_STRING_CLASS to indicate character classes. These
+ * correspond closely by name with what [string is] can support, but there is
+ * no requirement to keep the values the same.
+ */
+
+typedef enum InstStringClassType {
+ STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */
+ STR_CLASS_ALPHA, /* Unicode alphabet characters. */
+ STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */
+ STR_CLASS_CONTROL, /* Unicode control characters. */
+ STR_CLASS_DIGIT, /* Unicode digit characters. */
+ STR_CLASS_GRAPH, /* Unicode printing characters, excluding
+ * space. */
+ STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */
+ STR_CLASS_PRINT, /* Unicode printing characters, including
+ * spaces. */
+ STR_CLASS_PUNCT, /* Unicode punctuation characters. */
+ STR_CLASS_SPACE, /* Unicode space characters. */
+ STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */
+ STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
+ * punctuation) characters. */
+ STR_CLASS_XDIGIT /* Characters that can be used as digits in
+ * hexadecimal numbers ([0-9A-Fa-f]). */
+} InstStringClassType;
+
+typedef struct StringClassDesc {
+ const char *name; /* Name of the class. */
+ int (*comparator)(int); /* Function to test if a single unicode
+ * character is a member of the class. */
+} StringClassDesc;
+
+MODULE_SCOPE StringClassDesc const tclStringClassTable[];
+
+/*
* Compilation of some Tcl constructs such as if commands and the logical or
* (||) and logical and (&&) operators in expressions requires the generation
* of forward jumps. Since the PC target of these jumps isn't known when the
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index c7072ee..b818f18 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -564,6 +564,11 @@ FormatInstruction(
}
Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
+ case OPERAND_SCLS1:
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+ Tcl_AppendPrintfToObj(bufferObj, "%s ",
+ tclStringClassTable[opnd].name);
+ break;
case OPERAND_NONE:
default:
break;
@@ -988,6 +993,12 @@ DisassembleByteCodeAsDicts(
Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
"?%d", val));
break;
+ case OPERAND_SCLS1:
+ val = TclGetUInt1AtPtr(opnd);
+ opnd++;
+ Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf(
+ "=%s", tclStringClassTable[val].name));
+ break;
case OPERAND_NONE:
Tcl_Panic("opcode %d with more than zero 'no' operands", *pc);
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 5b42124..ac78370 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2494,9 +2494,12 @@ TEBCresume(
TRACE_APPEND(("\n"));
goto processExceptionReturn;
- case INST_YIELD: {
- CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ {
+ CoroutineData *corPtr;
+ int yieldParameter;
+ case INST_YIELD:
+ corPtr = iPtr->execEnvPtr->corPtr;
TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
if (!corPtr) {
TRACE_APPEND(("ERROR: yield outside coroutine\n"));
@@ -2510,11 +2513,74 @@ TEBCresume(
}
#ifdef TCL_COMPILE_DEBUG
- TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
- if (traceInstructions) {
- fprintf(stdout, "\n");
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ TRACE_APPEND(("YIELD...\n"));
+ } else {
+ fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ Tcl_GetString(OBJ_AT_TOS));
+ }
+ fflush(stdout);
+ }
+#endif
+ yieldParameter = 0;
+ Tcl_SetObjResult(interp, OBJ_AT_TOS);
+ goto doYield;
+
+ case INST_YIELD_TO_INVOKE:
+ corPtr = iPtr->execEnvPtr->corPtr;
+ valuePtr = OBJ_AT_TOS;
+ if (!corPtr) {
+ TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
+ O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto can only be called in a coroutine", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+ TRACE(("[%.30s] => ERROR: yield in deleted\n",
+ O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto called in deleted namespace", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
+ } else {
+ /* FIXME: What is the right thing to trace? */
+ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ Tcl_GetString(valuePtr));
+ }
+ fflush(stdout);
}
#endif
+
+ /*
+ * Install a tailcall record in the caller and continue with the
+ * yield. The yield is switched into multi-return mode (via the
+ * 'yieldParameter').
+ */
+
+ Tcl_IncrRefCount(valuePtr);
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ TclSetTailcall(interp, valuePtr);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/
+
+ doYield:
/* TIP #280: Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
*/
@@ -2529,11 +2595,8 @@ TEBCresume(
pc++;
cleanup = 1;
TEBC_YIELD();
-
- Tcl_SetObjResult(interp, OBJ_AT_TOS);
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
- INT2PTR(0), NULL, NULL);
-
+ INT2PTR(yieldParameter), NULL, NULL);
return TCL_OK;
}
@@ -2553,6 +2616,7 @@ TEBCresume(
}
#ifdef TCL_COMPILE_DEBUG
+ /* FIXME: What is the right thing to trace? */
{
register int i;
@@ -4539,6 +4603,7 @@ TEBCresume(
Object *oPtr;
CallFrame *framePtr;
CallContext *contextPtr;
+ int skip, newDepth;
case INST_TCLOO_SELF:
framePtr = iPtr->varFramePtr;
@@ -4563,9 +4628,111 @@ TEBCresume(
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
+ case INST_TCLOO_NEXT_CLASS:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ framePtr = iPtr->varFramePtr;
+ valuePtr = OBJ_AT_DEPTH(opnd - 2);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
+ skip = 2;
+ TRACE(("%d => ", opnd));
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE_APPEND(("ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "nextto may only be called from inside a method",
+ -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
+ if (oPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
+ goto gotError;
+ } else {
+ Class *classPtr = oPtr->classPtr;
+ struct MInvoke *miPtr;
+ int i;
+ const char *methodType;
+
+ if (classPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+ for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (!miPtr->isFilter &&
+ miPtr->mPtr->declaringClassPtr == classPtr) {
+ newDepth = i;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < opnd; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ goto doInvokeNext;
+ }
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
+ O2S(valuePtr)));
+ for (i=contextPtr->index ; i>=0 ; i--) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (miPtr->isFilter
+ || miPtr->mPtr->declaringClassPtr != classPtr) {
+ continue;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
case INST_TCLOO_NEXT:
opnd = TclGetUInt1AtPtr(pc+1);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
framePtr = iPtr->varFramePtr;
+ skip = 1;
TRACE(("%d => ", opnd));
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
@@ -4580,7 +4747,8 @@ TEBCresume(
}
contextPtr = framePtr->clientData;
- if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ newDepth = contextPtr->index + 1;
+ if (newDepth >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless
* the interpreter is being torn down, in which case we might be
@@ -4605,33 +4773,31 @@ TEBCresume(
Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
CACHE_STACK_INFO();
goto gotError;
- }
-
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
+ } else if (tclTraceExec >= 2) {
int i;
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
- TRACE(("next_in_chain "));
} else {
- fprintf(stdout, "%d: (%u) invoking next_in_chain ",
+ fprintf(stdout, "%d: (%u) invoking ",
iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
}
- for (i = 0; i < objc; i++) {
+ for (i = 0; i < opnd; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
- }
#endif /*TCL_COMPILE_DEBUG*/
+ }
+ doInvokeNext:
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
+ ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
}
pcAdjustment = 2;
@@ -4640,6 +4806,7 @@ TEBCresume(
iPtr->varFramePtr = framePtr->callerVarPtr;
pc += pcAdjustment;
TEBC_YIELD();
+
oPtr = contextPtr->oPtr;
if (oPtr->flags & FILTER_HANDLING) {
TclNRAddCallback(interp, FinalizeOONextFilter,
@@ -4650,20 +4817,21 @@ TEBCresume(
framePtr, contextPtr, INT2PTR(contextPtr->index),
INT2PTR(contextPtr->skip));
}
- if (contextPtr->callPtr->chain[++contextPtr->index].isFilter
+ contextPtr->skip = skip;
+ contextPtr->index = newDepth;
+ if (contextPtr->callPtr->chain[newDepth].isFilter
|| contextPtr->callPtr->flags & FILTER_HANDLING) {
oPtr->flags |= FILTER_HANDLING;
} else {
oPtr->flags &= ~FILTER_HANDLING;
}
- contextPtr->skip = 1;
+
{
register Method *const mPtr =
- contextPtr->callPtr->chain[contextPtr->index].mPtr;
+ contextPtr->callPtr->chain[newDepth].mPtr;
return mPtr->typePtr->callProc(mPtr->clientData, interp,
- (Tcl_ObjectContext) contextPtr, opnd,
- &OBJ_AT_DEPTH(opnd-1));
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
}
case INST_TCLOO_IS_OBJECT:
@@ -5642,6 +5810,25 @@ TEBCresume(
TclNewIntObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
+
+ case INST_STR_CLASS:
+ opnd = TclGetInt1AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
+ O2S(valuePtr)));
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ match = 1;
+ if (length > 0) {
+ end = ustring1 + length;
+ for (p=ustring1 ; p<end ; p++) {
+ if (!tclStringClassTable[opnd].comparator(*p)) {
+ match = 0;
+ break;
+ }
+ }
+ }
+ TRACE_APPEND(("%d\n", match));
+ JUMP_PEEPHOLE_F(match, 2, 1);
}
case INST_STR_MATCH:
@@ -5776,6 +5963,14 @@ TEBCresume(
int type1, type2;
long l1, l2, lResult;
+ case INST_NUM_TYPE:
+ if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
+ type1 = 0;
+ }
+ TclNewIntObj(objResultPtr, type1);
+ TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
+ NEXT_INST_F(1, 1, 1);
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
@@ -6453,6 +6648,17 @@ TEBCresume(
* -----------------------------------------------------------------
*/
+ case INST_TRY_CVT_TO_BOOLEAN:
+ valuePtr = OBJ_AT_TOS;
+ if (valuePtr->typePtr == &tclBooleanType) {
+ objResultPtr = TCONST(1);
+ } else {
+ int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
+ objResultPtr = TCONST(result);
+ }
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
@@ -9411,10 +9617,12 @@ IllegalExprOperandType(
ClientData ptr;
int type;
const unsigned char opcode = *pc;
- const char *description, *operator = operatorStrings[opcode - INST_LOR];
+ const char *description, *operator = "unknown";
if (opcode == INST_EXPON) {
operator = "**";
+ } else if (opcode <= INST_STR_NEQ) {
+ operator = operatorStrings[opcode - INST_LOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
diff --git a/generic/tclIO.c b/generic/tclIO.c
index f1d85bf..ac93329 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -1581,11 +1581,7 @@ Tcl_CreateChannel(
statePtr->timer = NULL;
statePtr->csPtrR = NULL;
statePtr->csPtrW = NULL;
-
statePtr->outputStage = NULL;
- if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
- }
/*
* As we are creating the channel, it is obviously the top for now.
@@ -2838,10 +2834,6 @@ CloseChannel(
}
Tcl_FreeEncoding(statePtr->encoding);
- if (statePtr->outputStage != NULL) {
- ckfree(statePtr->outputStage);
- statePtr->outputStage = NULL;
- }
}
/*
@@ -4163,196 +4155,155 @@ WriteChars(
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
- ChannelBuffer *bufPtr;
- char *dst, *stage;
- int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
- int stageLen, toWrite, stageRead, endEncoding, result;
- int consumedSomething, translate;
- Tcl_Encoding encoding;
- char safe[BUFFER_PADDING];
+ char *nextNewLine = NULL;
+ int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
+ Tcl_Encoding encoding = statePtr->encoding;
if (srcLen) {
WillWrite(chanPtr);
}
- total = 0;
- sawLF = 0;
- savedLF = 0;
- saved = 0;
- encoding = statePtr->encoding;
-
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
- translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED)
- || (statePtr->outputTranslation != TCL_TRANSLATE_LF);
-
- /*
- * Loop over all UTF-8 characters in src, storing them in staging buffer
- * with proper EOL translation.
- */
+ if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
+ || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
+ nextNewLine = memchr(src, '\n', srcLen);
+ }
- consumedSomething = 1;
- while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
- consumedSomething = 0;
- stage = statePtr->outputStage;
- stageMax = statePtr->bufSize;
- stageLen = stageMax;
+ while (srcLen + saved + endEncoding > 0) {
+ ChannelBuffer *bufPtr;
+ char *dst, safe[BUFFER_PADDING];
+ int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
- toWrite = stageLen;
- if (toWrite > srcLen) {
- toWrite = srcLen;
+ if (nextNewLine) {
+ srcLimit = nextNewLine - src;
}
-
- if (translate) {
- if (savedLF) {
- /*
- * A '\n' was left over from last call to TranslateOutputEOL()
- * and we need to store it in the staging buffer. If the
- * channel is line-based, we will need to flush the output
- * buffer (after translating the staging buffer).
- */
-
- *stage++ = '\n';
- stageLen--;
- sawLF++;
- }
- if (TranslateOutputEOL(statePtr, stage, src, &stageLen,
- &toWrite)) {
- sawLF++;
- }
-
- stage -= savedLF;
- stageLen += savedLF;
- savedLF = 0;
-
- if (stageLen > stageMax) {
- savedLF = 1;
- stageLen = stageMax;
- }
- } else {
- memcpy(stage, src, toWrite);
- stageLen = toWrite;
+
+ /* Get space to write into */
+ bufPtr = statePtr->curOutPtr;
+ if (bufPtr == NULL) {
+ bufPtr = AllocChannelBuffer(statePtr->bufSize);
+ statePtr->curOutPtr = bufPtr;
}
- src += toWrite;
- srcLen -= toWrite;
-
- /*
- * Loop over all UTF-8 characters in staging buffer, converting them
- * to external encoding, storing them in output buffer.
- */
-
- while (stageLen + saved + endEncoding > 0) {
- bufPtr = statePtr->curOutPtr;
- if (bufPtr == NULL) {
- bufPtr = AllocChannelBuffer(statePtr->bufSize);
- statePtr->curOutPtr = bufPtr;
- }
- dst = InsertPoint(bufPtr);
- dstLen = SpaceLeft(bufPtr);
-
- if (saved != 0) {
- /*
- * Here's some translated bytes left over from the last buffer
- * that we need to stick at the beginning of this buffer.
- */
-
- memcpy(dst, safe, (size_t) saved);
- bufPtr->nextAdded += saved;
- dst += saved;
- dstLen -= saved;
- saved = 0;
- }
-
- result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen,
- statePtr->outputEncodingFlags,
- &statePtr->outputEncodingState, dst,
- dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL);
-
+ if (saved) {
/*
- * Fix for SF #506297, reported by Martin Forssen
- * <ruric@users.sourceforge.net>.
- *
- * The encoding chosen in the script exposing the bug writes out
- * three intro characters when TCL_ENCODING_START is set, but does
- * not consume any input as TCL_ENCODING_END is cleared. As some
- * output was generated the enclosing loop calls UtfToExternal
- * again, again with START set. Three more characters in the out
- * and still no use of input ... To break this infinite loop we
- * remove TCL_ENCODING_START from the set of flags after the first
- * call (no condition is required, the later calls remove an unset
- * flag, which is a no-op). This causes the subsequent calls to
- * UtfToExternal to consume and convert the actual input.
+ * Here's some translated bytes left over from the last buffer
+ * that we need to stick at the beginning of this buffer.
*/
- statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+ memcpy(InsertPoint(bufPtr), safe, (size_t) saved);
+ bufPtr->nextAdded += saved;
+ saved = 0;
+ }
+ dst = InsertPoint(bufPtr);
+ dstLen = SpaceLeft(bufPtr);
+
+ result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
+ statePtr->outputEncodingFlags,
+ &statePtr->outputEncodingState, dst,
+ dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
+
+ /* See chan-io-1.[89]. Tcl Bug 506297. */
+ statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+
+ if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
+ /* We're reading from invalid/incomplete UTF-8 */
+ if (total == 0) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
+ break;
+ }
- /*
- * The following code must be executed only when result is not 0.
- */
+ bufPtr->nextAdded += dstWrote;
+ src += srcRead;
+ srcLen -= srcRead;
+ total += dstWrote;
+ dst += dstWrote;
+ dstLen -= dstWrote;
- if ((result != 0) && (stageRead + dstWrote == 0)) {
- /*
- * We have an incomplete UTF-8 character at the end of the
- * staging buffer. It will get moved to the beginning of the
- * staging buffer followed by more bytes from src.
- */
+ if (src == nextNewLine && dstLen > 0) {
+ static char crln[3] = "\r\n";
+ char *nl = NULL;
+ int nlLen = 0;
- src -= stageLen;
- srcLen += stageLen;
- stageLen = 0;
- savedLF = 0;
+ switch (statePtr->outputTranslation) {
+ case TCL_TRANSLATE_LF:
+ nl = crln + 1;
+ nlLen = 1;
+ break;
+ case TCL_TRANSLATE_CR:
+ nl = crln;
+ nlLen = 1;
+ break;
+ case TCL_TRANSLATE_CRLF:
+ nl = crln;
+ nlLen = 2;
+ break;
+ default:
+ Tcl_Panic("unknown output translation requested");
break;
}
- bufPtr->nextAdded += dstWrote;
- if (IsBufferOverflowing(bufPtr)) {
- /*
- * When translating from UTF-8 to external encoding, we
- * allowed the translation to produce a character that crossed
- * the end of the output buffer, so that we would get a
- * completely full buffer before flushing it. The extra bytes
- * will be moved to the beginning of the next buffer.
- */
+
+ result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
+ statePtr->outputEncodingFlags,
+ &statePtr->outputEncodingState, dst,
+ dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
- saved = -SpaceLeft(bufPtr);
- memcpy(safe, dst + dstLen, (size_t) saved);
- bufPtr->nextAdded = bufPtr->bufLength;
- }
- if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
- return -1;
+ if (srcRead != nlLen) {
+ Tcl_Panic("Can This Happen?");
}
+ bufPtr->nextAdded += dstWrote;
+ src++;
+ srcLen--;
total += dstWrote;
- stage += stageRead;
- stageLen -= stageRead;
- sawLF = 0;
-
- consumedSomething = 1;
+ dst += dstWrote;
+ dstLen -= dstWrote;
+ nextNewLine = memchr(src, '\n', srcLen);
+ needNlFlush = 1;
+ }
+ if (IsBufferOverflowing(bufPtr)) {
/*
- * If all translated characters are written to the buffer,
- * endEncoding is set to 0 because the escape sequence may be
- * output.
+ * When translating from UTF-8 to external encoding, we
+ * allowed the translation to produce a character that crossed
+ * the end of the output buffer, so that we would get a
+ * completely full buffer before flushing it. The extra bytes
+ * will be moved to the beginning of the next buffer.
*/
- if ((stageLen + saved == 0) && (result == 0)) {
- endEncoding = 0;
- }
+ saved = -SpaceLeft(bufPtr);
+ memcpy(safe, dst + dstLen, (size_t) saved);
+ bufPtr->nextAdded = bufPtr->bufLength;
}
- }
- /*
- * If nothing was written and it happened because there was no progress in
- * the UTF conversion, we throw an error.
- */
+ if ((srcLen + saved == 0) && (result == TCL_OK)) {
+ endEncoding = 0;
+ }
- if (!consumedSomething && (total == 0)) {
- Tcl_SetErrno(EINVAL);
- return -1;
+ if (IsBufferFull(bufPtr)) {
+ if (FlushChannel(NULL, chanPtr, 0) != 0) {
+ return -1;
+ }
+ flushed += statePtr->bufSize;
+ if (saved == 0 || src[-1] != '\n') {
+ needNlFlush = 0;
+ }
+ }
}
+ if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) ||
+ (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) {
+ SetFlag(statePtr, BUFFER_READY);
+ if (FlushChannel(NULL, chanPtr, 0) != 0) {
+ return -1;
+ }
+ }
+
return total;
}
@@ -7594,14 +7545,6 @@ Tcl_SetChannelBufferSize(
statePtr = ((Channel *) chan)->state;
statePtr->bufSize = sz;
-
- if (statePtr->outputStage != NULL) {
- ckfree(statePtr->outputStage);
- statePtr->outputStage = NULL;
- }
- if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
- }
}
/*
@@ -8242,17 +8185,6 @@ Tcl_SetChannelOption(
statePtr->inQueueTail = NULL;
}
- /*
- * If encoding or bufsize changes, need to update output staging buffer.
- */
-
- if (statePtr->outputStage != NULL) {
- ckfree(statePtr->outputStage);
- statePtr->outputStage = NULL;
- }
- if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
- statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
- }
return TCL_OK;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3aaa30b..a9f4c16 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3592,6 +3592,9 @@ MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3619,6 +3622,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3685,6 +3691,9 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9a0682d..de00733 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -440,8 +440,9 @@ InitFoundation(
cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
NULL, TclOONextObjCmd, NULL, NULL);
cmdPtr->compileProc = TclCompileObjectNextCmd;
- Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
NULL, TclOONextToObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextToCmd;
cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
TclOOSelfObjCmd, NULL, NULL);
cmdPtr->compileProc = TclCompileObjectSelfCmd;
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 6084cf2..0b0516b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -821,6 +821,7 @@ TclOONextToObjCmd(
CallContext *contextPtr;
int i;
Tcl_Object object;
+ const char *methodType;
/*
* Start with sanity checks on the calling context to make sure that we
@@ -886,19 +887,30 @@ TclOONextToObjCmd(
* is on the chain but unreachable, or not on the chain at all.
*/
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
for (i=contextPtr->index ; i>=0 ; i--) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "method implementation by \"%s\" not reachable from here",
- TclGetString(objv[1])));
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+ NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "method has no non-filter implementation by \"%s\"",
- TclGetString(objv[1])));
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index e495c2e..dffa38c 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1281,23 +1281,43 @@ Tcl_AppendObjToObj(
if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
&& TclIsPureByteArray(appendObjPtr)) {
- unsigned char *bytesSrc;
- int lengthSrc, lengthTotal;
/*
- * We do not assume that objPtr and appendObjPtr must be distinct!
- * This makes this code a bit more complex than it otherwise would be,
- * but in turn makes it much safer.
+ * You might expect the code here to be
+ *
+ * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length);
+ * TclAppendBytesToByteArray(objPtr, bytes, length);
+ *
+ * and essentially all of the time that would be fine. However,
+ * it would run into trouble in the case where objPtr and
+ * appendObjPtr point to the same thing. That may never be a
+ * good idea. It seems to violate Copy On Write, and we don't
+ * have any tests for the situation, since making any Tcl commands
+ * that call Tcl_AppendObjToObj() do that appears impossible
+ * (They honor Copy On Write!). For the sake of extensions that
+ * go off into that realm, though, here's a more complex approach
+ * that can handle all the cases.
*/
+ /* Get lengths */
+ int lengthSrc;
+
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
- lengthTotal = length + lengthSrc;
- if (((length > lengthSrc) ? length : lengthSrc) > lengthTotal) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
- bytesSrc = Tcl_GetByteArrayFromObj(appendObjPtr, NULL);
- TclAppendBytesToByteArray(objPtr, bytesSrc, lengthSrc);
+
+ /* Grow buffer enough for the append */
+ TclAppendBytesToByteArray(objPtr, NULL, lengthSrc);
+
+ /* Reset objPtr back to the original value */
+ Tcl_SetByteArrayLength(objPtr, length);
+
+ /*
+ * Now do the append knowing that buffer growth cannot cause
+ * any trouble.
+ */
+
+ TclAppendBytesToByteArray(objPtr,
+ Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc);
return;
}
diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h
index 669f10b..030e4ec 100644
--- a/generic/tclStringTrim.h
+++ b/generic/tclStringTrim.h
@@ -23,32 +23,7 @@
* UTF-8 literal string containing all Unicode space characters. [TIP #413]
*/
-#define DEFAULT_TRIM_SET \
- "\x09\x0a\x0b\x0c\x0d " /* ASCII */\
- "\xc0\x80" /* nul (U+0000) */\
- "\xc2\x85" /* next line (U+0085) */\
- "\xc2\xa0" /* non-breaking space (U+00a0) */\
- "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \
- "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\
- "\xe2\x80\x80" /* en quad (U+2000) */\
- "\xe2\x80\x81" /* em quad (U+2001) */\
- "\xe2\x80\x82" /* en space (U+2002) */\
- "\xe2\x80\x83" /* em space (U+2003) */\
- "\xe2\x80\x84" /* three-per-em space (U+2004) */\
- "\xe2\x80\x85" /* four-per-em space (U+2005) */\
- "\xe2\x80\x86" /* six-per-em space (U+2006) */\
- "\xe2\x80\x87" /* figure space (U+2007) */\
- "\xe2\x80\x88" /* punctuation space (U+2008) */\
- "\xe2\x80\x89" /* thin space (U+2009) */\
- "\xe2\x80\x8a" /* hair space (U+200a) */\
- "\xe2\x80\x8b" /* zero width space (U+200b) */\
- "\xe2\x80\xa8" /* line separator (U+2028) */\
- "\xe2\x80\xa9" /* paragraph separator (U+2029) */\
- "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\
- "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\
- "\xe2\x81\xa0" /* word joiner (U+2060) */\
- "\xe3\x80\x80" /* ideographic space (U+3000) */\
- "\xef\xbb\xbf" /* zero width no-break space (U+feff) */
+MODULE_SCOPE const char tclDefaultTrimSet[];
/*
* The whitespace trimming set used when [concat]enating. This is a subset of
diff --git a/tests/coroutine.test b/tests/coroutine.test
index a360fd5..05b58c9 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -1,4 +1,4 @@
-# Commands covered: coroutine, yield, [info coroutine]
+# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -612,7 +612,6 @@ test coroutine-7.3 {yielding between coroutines} -body {
} -cleanup {
catch {rename juggler ""}
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
-
test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
proc foo {a b} {catch yield; return 1}
} -cleanup {
@@ -620,7 +619,6 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
} -body {
coroutine demo lsort -command foo {a b}
} -result {b a}
-
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
@@ -628,14 +626,12 @@ test coroutine-7.5 {return codes} {
}
set result
} {0 1 2 3 4 5}
-
test coroutine-7.6 {Early yield crashes} {
proc foo args {}
trace add execution foo enter {catch yield}
coroutine demo foo
rename foo {}
} {}
-
test coroutine-7.7 {Bug 2486550} -setup {
interp hide {} yield
} -body {
@@ -644,6 +640,92 @@ test coroutine-7.7 {Bug 2486550} -setup {
demo
interp expose {} yield
} -result ok
+test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ yieldto ::return -level 0 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ namespace delete cotest
+ namespace eval cotest {}
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ set y ::yieldto
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ $y ::return -level 0 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ namespace delete cotest
+ namespace eval cotest {}
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ set y ::yieldto
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ $y ::return -level 0 -cotest [namespace delete ::cotest] 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
# cleanup
diff --git a/unix/configure b/unix/configure
index 0e231ab..d3951b6 100755
--- a/unix/configure
+++ b/unix/configure
@@ -7008,6 +7008,7 @@ fi
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a'
+ TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a'
echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
if test "${ac_cv_cygwin+set}" = set; then
@@ -7741,6 +7742,7 @@ fi
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$@"
+ TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 8c29334..cb6704b 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1218,6 +1218,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a'
+ TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a'
AC_CACHE_CHECK(for Cygwin version of gcc,
ac_cv_cygwin,
AC_TRY_COMPILE([
@@ -1531,6 +1532,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -shared"
TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$[@]"
+ TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index f07b123..f8acad5 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -33,7 +33,10 @@
#endif
#ifdef __CYGWIN__
-DLLIMPORT extern __stdcall unsigned char GetVersionExA(void *);
+DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
+DLLIMPORT extern __stdcall void *LoadLibraryW(const void *);
+DLLIMPORT extern __stdcall void FreeLibrary(void *);
+DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
DLLIMPORT extern __stdcall void GetSystemInfo(void *);
#define NUMPLATFORMS 4
@@ -66,14 +69,14 @@ typedef struct _SYSTEM_INFO {
int wProcessorRevision;
} SYSTEM_INFO;
-typedef struct _OSVERSIONINFOA {
+typedef struct _OSVERSIONINFOW {
DWORD dwOSVersionInfoSize;
DWORD dwMajorVersion;
DWORD dwMinorVersion;
DWORD dwBuildNumber;
DWORD dwPlatformId;
- char szCSDVersion[128];
-} OSVERSIONINFOA;
+ wchar_t szCSDVersion[128];
+} OSVERSIONINFOW;
#endif
#ifdef HAVE_COREFOUNDATION
@@ -747,7 +750,8 @@ TclpSetVariables(
{
#ifdef __CYGWIN__
SYSTEM_INFO sysInfo;
- OSVERSIONINFOA osInfo;
+ static OSVERSIONINFOW osInfo;
+ static int osInfoInitialized = 0;
char buffer[TCL_INTEGER_SPACE * 2];
#elif !defined(NO_UNAME)
struct utsname name;
@@ -860,8 +864,19 @@ TclpSetVariables(
unameOK = 0;
#ifdef __CYGWIN__
unameOK = 1;
- osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
- GetVersionExA(&osInfo);
+ if (!osInfoInitialized) {
+ HANDLE handle = LoadLibraryW(L"NTDLL");
+ int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion");
+ osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+ if (!getversion || getversion(&osInfo)) {
+ GetVersionExW(&osInfo);
+ }
+ if (handle) {
+ FreeLibrary(handle);
+ }
+ osInfoInitialized = 1;
+ }
+
GetSystemInfo(&sysInfo);
if (osInfo.dwPlatformId < NUMPLATFORMS) {
diff --git a/win/makefile.vc b/win/makefile.vc
index 19b5614..8c65bd0 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -989,7 +989,7 @@ $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c
$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
@nmakehlp -s << $** >$@
@MACHINE@ $(MACHINE:IX86=X86)
-@TCL_WIN_VERSION@ $(TCL_DOTVERSION).0.0
+@TCL_WIN_VERSION@ $(DOTVERSION).0.0
<<
#---------------------------------------------------------------------
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 7b027c5..b3f8f41 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -530,7 +530,8 @@ TclpSetVariables(
SYSTEM_INFO info;
OemId oemId;
} sys;
- OSVERSIONINFOW osInfo;
+ static OSVERSIONINFOW osInfo;
+ static int osInfoInitialized = 0;
Tcl_DString ds;
TCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
@@ -538,9 +539,18 @@ TclpSetVariables(
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
- osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
- GetVersionExW(&osInfo);
-
+ if (!osInfoInitialized) {
+ HANDLE handle = LoadLibraryW(L"NTDLL");
+ int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion");
+ osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+ if (!getversion || getversion(&osInfo)) {
+ GetVersionExW(&osInfo);
+ }
+ if (handle) {
+ FreeLibrary(handle);
+ }
+ osInfoInitialized = 1;
+ }
GetSystemInfo(&sys.info);
/*
generated by cgit v0.12 at 2024-11-18 17:54:55 (GMT)