summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/scan.n4
-rw-r--r--generic/tcl.h2
-rw-r--r--generic/tclAssembly.c34
-rw-r--r--generic/tclCompCmds.c53
-rw-r--r--generic/tclCompCmdsGR.c27
-rw-r--r--generic/tclCompCmdsSZ.c16
-rw-r--r--generic/tclCompExpr.c4
-rw-r--r--generic/tclCompile.c325
-rw-r--r--generic/tclCompile.h1
-rw-r--r--generic/tclEnsemble.c4
-rw-r--r--generic/tclOptimize.c18
-rw-r--r--generic/tclScan.c6
-rw-r--r--library/http/http.tcl21
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--tests/compile.test64
-rw-r--r--tests/for.test242
-rw-r--r--tests/http.test4
-rw-r--r--tests/scan.test17
-rw-r--r--unix/Makefile.in4
-rw-r--r--win/Makefile.in4
20 files changed, 724 insertions, 128 deletions
diff --git a/doc/scan.n b/doc/scan.n
index 3cb0320..8689621 100644
--- a/doc/scan.n
+++ b/doc/scan.n
@@ -99,7 +99,7 @@ The input substring must be an octal integer. It is read in and the
integer value is stored in the variable,
truncated as required by the size modifier value.
.TP
-\fBx\fR
+\fBx\fR or \fBX\fR
.
The input substring must be a hexadecimal integer.
It is read in and the integer value is stored in the variable,
@@ -140,7 +140,7 @@ substring may be a white-space character.
The input substring consists of all the characters up to the next
white-space character; the characters are copied to the variable.
.TP
-\fBe\fR or \fBf\fR or \fBg\fR
+\fBe\fR or \fBf\fR or \fBg\fR or \fBE\fR or \fBG\fR
.
The input substring must be a floating-point number consisting
of an optional sign, a string of decimal digits possibly
diff --git a/generic/tcl.h b/generic/tcl.h
index ba94281..4cbcebf 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -149,7 +149,7 @@ extern "C" {
*/
#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1)))
-# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5))
+# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5))
# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg)))
# else
# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__))
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 946c729..fc51457 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -246,6 +246,8 @@ static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
int opnd, int count);
static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
int param, int count);
+static void BBEmitInvoke1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
+ int param, int count);
static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
int count);
static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
@@ -679,10 +681,13 @@ BBEmitInstInt4(
/*
*-----------------------------------------------------------------------------
*
- * BBEmitInst1or4 --
+ * BBEmitInst1or4, BBEmitInvoke1or4 --
*
* Emits a 1- or 4-byte operation according to the magnitude of the
- * operand
+ * operand. The Invoke variant generates wrapping stack-balance
+ * management if necessary (which is not normally required in assembled
+ * code, as loop exception ranges, expansions, breaks and continues can't
+ * be issued currently).
*
*-----------------------------------------------------------------------------
*/
@@ -714,6 +719,29 @@ BBEmitInst1or4(
TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
+
+static void
+BBEmitInvoke1or4(
+ AssemblyEnv* assemEnvPtr, /* Assembly environment */
+ int tblIdx, /* Index in TalInstructionTable of op */
+ int param, /* Variable-length parameter */
+ int count) /* Arity if variadic */
+{
+ CompileEnv* envPtr = assemEnvPtr->envPtr;
+ /* Compilation environment */
+ BasicBlock* bbPtr = assemEnvPtr->curr_bb;
+ /* Current basic block */
+ int op = TalInstructionTable[tblIdx].tclInstCode;
+
+ if (param <= 0xff) {
+ op >>= 8;
+ } else {
+ op &= 0xff;
+ }
+ TclEmitInvoke(envPtr, op, param);
+ TclUpdateAtCmdStart(op, envPtr);
+ BBUpdateStackReqs(bbPtr, tblIdx, count);
+}
/*
*-----------------------------------------------------------------------------
@@ -1450,7 +1478,7 @@ AssembleOneLine(
goto cleanup;
}
- BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd);
+ BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd);
break;
case ASSEM_JUMP:
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 7e6b6da..9c43bfe 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -269,7 +269,7 @@ TclCompileArraySetCmd(
if (isDataValid && !isDataEven) {
PushStringLiteral(envPtr, "list must have an even number of elements");
PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
- TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr);
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
TclEmitInt4( 0, envPtr);
goto done;
}
@@ -354,7 +354,7 @@ TclCompileArraySetCmd(
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
PushStringLiteral(envPtr, "list must have an even number of elements");
PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
- TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr);
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
TclEmitInt4( 0, envPtr);
TclAdjustStackDepth(-1, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
@@ -620,7 +620,7 @@ TclCompileCatchCmd(
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_EVAL_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_EVAL_STK);
}
/* Stack at this point:
* nonsimple: script <mark> result
@@ -1675,7 +1675,7 @@ TclCompileDictUpdateCmd(
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
@@ -2033,7 +2033,7 @@ TclCompileDictWithCmd(
} else {
TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
}
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
/*
* Prepare for the start of the next command.
@@ -2135,19 +2135,48 @@ TclCompileErrorCmd(
{
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
- * However, we only deal with the case where there is just a message.
*/
- Tcl_Token *messageTokenPtr;
+
+ Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
- if (parsePtr->numWords != 2) {
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
- messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushStringLiteral(envPtr, "-code error -level 0");
- CompileWord(envPtr, messageTokenPtr, interp, 1);
- TclEmitOpcode(INST_RETURN_STK, envPtr);
+ /*
+ * Handle the message.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Construct the options. Note that -code and -level are not here.
+ */
+
+ if (parsePtr->numWords == 2) {
+ PushStringLiteral(envPtr, "");
+ } else {
+ PushStringLiteral(envPtr, "-errorinfo");
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ if (parsePtr->numWords == 3) {
+ TclEmitInstInt4( INST_LIST, 2, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "-errorcode");
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+ TclEmitInstInt4( INST_LIST, 4, envPtr);
+ }
+ }
+
+ /*
+ * Issue the error via 'returnImm error 0'.
+ */
+
+ TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
return TCL_OK;
}
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 43ea3d3..d00327d 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -2367,7 +2367,7 @@ TclCompileReturnCmd(
CompileWord(envPtr, optsTokenPtr, interp, 2);
CompileWord(envPtr, msgTokenPtr, interp, 3);
- TclEmitOpcode(INST_RETURN_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
return TCL_OK;
}
@@ -2381,6 +2381,10 @@ TclCompileReturnCmd(
* Scan through the return options. If any are unknown at compile time,
* there is no value in bytecompiling. Save the option values known in an
* objv array for merging into a return options dictionary.
+ *
+ * TODO: There is potential for improvement if all option keys are known
+ * at compile time and all option values relating to '-code' and '-level'
+ * are known at compile time.
*/
for (objc = 0; objc < numOptionWords; objc++) {
@@ -2388,7 +2392,7 @@ TclCompileReturnCmd(
Tcl_IncrRefCount(objv[objc]);
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
/*
- * Non-literal, so punt to run-time.
+ * Non-literal, so punt to run-time assembly of the dictionary.
*/
for (; objc>=0 ; objc--) {
@@ -2509,7 +2513,7 @@ TclCompileReturnCmd(
* Issue the RETURN itself.
*/
- TclEmitOpcode(INST_RETURN_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
return TCL_OK;
}
@@ -2521,6 +2525,23 @@ CompileReturnInternal(
int level,
Tcl_Obj *returnOpts)
{
+ if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) {
+ ExceptionRange *rangePtr;
+ ExceptionAux *exceptAux;
+
+ rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ TclCleanupStackForBreakContinue(envPtr, exceptAux);
+ if (code == TCL_BREAK) {
+ TclAddLoopBreakFixup(envPtr, exceptAux);
+ } else {
+ TclAddLoopContinueFixup(envPtr, exceptAux);
+ }
+ Tcl_DecrRefCount(returnOpts);
+ return;
+ }
+ }
+
TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
TclEmitInstInt4(op, code, envPtr);
TclEmitInt4(level, envPtr);
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 44cb66e..754238f 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -99,6 +99,8 @@ const AuxDataType tclJumptableInfoType = {
if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
+#define INVOKE(name) \
+ TclEmitInvoke(envPtr,INST_##name)
/*
*----------------------------------------------------------------------
@@ -873,7 +875,7 @@ TclSubstCompile(
OP( END_CATCH);
OP( RETURN_CODE_BRANCH);
- /* ERROR -> reraise it */
+ /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */
OP( RETURN_STK);
OP( NOP);
@@ -1965,7 +1967,7 @@ TclCompileThrowCmd(
OP( LIST_LENGTH);
OP1( JUMP_FALSE1, 16);
OP4( LIST, 2);
- OP44( RETURN_IMM, 1, 0);
+ OP44( RETURN_IMM, TCL_ERROR, 0);
TclAdjustStackDepth(2, envPtr);
OP( POP);
OP( POP);
@@ -1974,7 +1976,7 @@ TclCompileThrowCmd(
PUSH( "type must be non-empty list");
PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}");
}
- OP44( RETURN_IMM, 1, 0);
+ OP44( RETURN_IMM, TCL_ERROR, 0);
return TCL_OK;
}
@@ -2396,7 +2398,7 @@ IssueTryClausesInstructions(
TclAdjustStackDepth(-1, envPtr);
FIXJUMP1( dontChangeOptions);
OP4( REVERSE, 2);
- OP( RETURN_STK);
+ INVOKE( RETURN_STK);
}
JUMP4( JUMP, addrsToFix[i]);
@@ -2415,7 +2417,7 @@ IssueTryClausesInstructions(
OP( POP);
LOAD( optionsVar);
LOAD( resultVar);
- OP( RETURN_STK);
+ INVOKE( RETURN_STK);
/*
* Fix all the jumps from taken clauses to here (which is the end of the
@@ -2724,7 +2726,7 @@ IssueTryClausesFinallyInstructions(
FIXJUMP1( finalOK);
LOAD( optionsVar);
LOAD( resultVar);
- OP( RETURN_STK);
+ INVOKE( RETURN_STK);
return TCL_OK;
}
@@ -2783,7 +2785,7 @@ IssueTryFinallyInstructions(
OP1( JUMP1, 7);
FIXJUMP1( jumpOK);
OP4( REVERSE, 2);
- OP( RETURN_STK);
+ INVOKE( RETURN_STK);
return TCL_OK;
}
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 50577b4..a5b69a2 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2335,9 +2335,9 @@ CompileExprTree(
*/
if (numWords < 255) {
- TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords);
} else {
- TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords);
}
/*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d15ef3a..3c8e4ef 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1738,9 +1738,9 @@ TclCompileInvocation(
}
if (wordIdx <= 255) {
- TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx);
} else {
- TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx);
}
}
@@ -1755,7 +1755,6 @@ CompileExpanded(
int wordIdx = 0;
DefineLineInformation;
-
StartExpanding(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
@@ -1787,24 +1786,20 @@ CompileExpanded(
}
/*
- * The stack depth during argument expansion can only be
- * managed at runtime, as the number of elements in the
- * expanded lists is not known at compile time. We adjust here
- * the stack depth estimate so that it is correct after the
- * command with expanded arguments returns.
+ * The stack depth during argument expansion can only be managed at
+ * runtime, as the number of elements in the expanded lists is not known
+ * at compile time. We adjust here the stack depth estimate so that it is
+ * correct after the command with expanded arguments returns.
*
- * The end effect of this command's invocation is that all the
- * words of the command are popped from the stack, and the
- * result is pushed: the stack top changes by (1-wordIdx).
+ * The end effect of this command's invocation is that all the words of
+ * the command are popped from the stack, and the result is pushed: the
+ * stack top changes by (1-wordIdx).
*
- * Note that the estimates are not correct while the command
- * is being prepared and run, INST_EXPAND_STKTOP is not
- * stack-neutral in general.
+ * Note that the estimates are not correct while the command is being
+ * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general.
*/
- TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
- envPtr->expandCount--;
- TclAdjustStackDepth(1 - wordIdx, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx);
}
static int
@@ -1818,8 +1813,8 @@ CompileCmdCompileProc(
DefineLineInformation;
/*
- * Emit of the INST_START_CMD instruction is controlled by
- * the value of envPtr->atCmdStart:
+ * Emit of the INST_START_CMD instruction is controlled by the value of
+ * envPtr->atCmdStart:
*
* atCmdStart == 2 : We are not using the INST_START_CMD instruction.
* atCmdStart == 1 : INST_START_CMD was the last instruction emitted.
@@ -1850,9 +1845,10 @@ CompileCmdCompileProc(
if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) {
if (incrOffset >= 0) {
/*
- * We successfully compiled a command. Increment the number
- * of commands that start at the currently active INST_START_CMD.
+ * We successfully compiled a command. Increment the number of
+ * commands that start at the currently active INST_START_CMD.
*/
+
unsigned char *incrPtr = envPtr->codeStart + incrOffset;
unsigned char *startPtr = incrPtr - 5;
@@ -1868,9 +1864,9 @@ CompileCmdCompileProc(
envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */
/*
- * Throw out any line information generated by the failed
- * compile attempt.
+ * Throw out any line information generated by the failed compile attempt.
*/
+
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
ckfree(mapPtr->loc[mapPtr->nuloc].line);
@@ -1878,11 +1874,11 @@ CompileCmdCompileProc(
}
/*
- * Reset the index of next command.
- * Toss out any from failed nested partial compiles.
+ * Reset the index of next command. Toss out any from failed nested
+ * partial compiles.
*/
- envPtr->numCommands = mapPtr->nuloc;
+ envPtr->numCommands = mapPtr->nuloc;
return TCL_ERROR;
}
@@ -1914,11 +1910,10 @@ CompileCommandTokens(
parsePtr->commandStart - envPtr->source, startCodeOffset);
/*
- * TIP #280. Scan the words and compute the extended location
- * information. The map first contain full per-word line
- * information for use by the compiler. This is later replaced by
- * a reduced form which signals non-literal words, stored in
- * 'wlines'.
+ * TIP #280. Scan the words and compute the extended location information.
+ * The map first contain full per-word line information for use by the
+ * compiler. This is later replaced by a reduced form which signals
+ * non-literal words, stored in 'wlines'.
*/
EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
@@ -1940,8 +1935,8 @@ CompileCommandTokens(
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if (cmdPtr) {
/*
- * Found a command. Test the ways we can be told
- * not to attempt to compile it.
+ * Found a command. Test the ways we can be told not to attempt
+ * to compile it.
*/
if ((cmdPtr->compileProc == NULL)
|| (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION)
@@ -1985,8 +1980,8 @@ CompileCommandTokens(
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
/*
- * TIP #280: Free full form of per-word line data and insert the
- * reduced form now
+ * TIP #280: Free full form of per-word line data and insert the reduced
+ * form now
*/
envPtr->line = cmdLine;
@@ -2071,20 +2066,20 @@ TclCompileScript(
if (parse.numWords == 0) {
/*
- * The "command" parsed has no words. In this case
- * we can skip the rest of the loop body. With no words,
- * clearly CompileCommandTokens() has nothing to do. Since
- * the parser aggressively sucks up leading comment and white
- * space, including newlines, parse.commandStart must be
- * pointing at either the end of script, or a command-terminating
- * semi-colon. In either case, the TclAdvance*() calls have
- * nothing to do. Finally, when no words are parsed, no
- * tokens have been allocated at parse.tokenPtr so there's
- * also nothing for Tcl_FreeParse() to do.
+ * The "command" parsed has no words. In this case we can skip
+ * the rest of the loop body. With no words, clearly
+ * CompileCommandTokens() has nothing to do. Since the parser
+ * aggressively sucks up leading comment and white space,
+ * including newlines, parse.commandStart must be pointing at
+ * either the end of script, or a command-terminating semi-colon.
+ * In either case, the TclAdvance*() calls have nothing to do.
+ * Finally, when no words are parsed, no tokens have been
+ * allocated at parse.tokenPtr so there's also nothing for
+ * Tcl_FreeParse() to do.
*
* The advantage of this shortcut is that CompileCommandTokens()
- * can be written with an assumption that parse.numWords > 0,
- * with the implication the CCT() always generates bytecode.
+ * can be written with an assumption that parse.numWords > 0, with
+ * the implication the CCT() always generates bytecode.
*/
continue;
}
@@ -2103,23 +2098,25 @@ TclCompileScript(
if (lastCmdIdx == -1) {
/*
- * Compiling the script yielded no bytecode. The script must be
- * all whitespace, comments, and empty commands. Such scripts
- * are defined to successfully produce the empty string result,
- * so we emit the simple bytecode that makes that happen.
+ * Compiling the script yielded no bytecode. The script must be all
+ * whitespace, comments, and empty commands. Such scripts are defined
+ * to successfully produce the empty string result, so we emit the
+ * simple bytecode that makes that happen.
*/
+
PushStringLiteral(envPtr, "");
} else {
/*
* We compiled at least one command to bytecode. The routine
* CompileCommandTokens() follows the bytecode of each compiled
- * command with an INST_POP, so that stack balance is maintained
- * when several commands are in sequence. (The result of each
- * command is thrown away before moving on to the next command).
- * For the last command compiled, we need to undo that INST_POP
- * so that the result of the last command becomes the result of
- * the script. The code here removes that trailing INST_POP.
+ * command with an INST_POP, so that stack balance is maintained when
+ * several commands are in sequence. (The result of each command is
+ * thrown away before moving on to the next command). For the last
+ * command compiled, we need to undo that INST_POP so that the result
+ * of the last command becomes the result of the script. The code
+ * here removes that trailing INST_POP.
*/
+
envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--;
envPtr->codeNext--;
envPtr->currStackDepth++;
@@ -2458,7 +2455,7 @@ TclCompileCmdWord(
*/
TclCompileTokens(interp, tokenPtr, count, envPtr);
- TclEmitOpcode(INST_EVAL_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_EVAL_STK);
}
}
@@ -3355,9 +3352,9 @@ TclAddLoopContinueFixup(
*
* TclCleanupStackForBreakContinue --
*
- * Ditch the extra elements from the auxiliary stack and the main
- * stack. How to do this exactly depends on whether there are any
- * elements on the auxiliary stack to pop.
+ * Ditch the extra elements from the auxiliary stack and the main stack.
+ * How to do this exactly depends on whether there are any elements on
+ * the auxiliary stack to pop.
*
* ---------------------------------------------------------------------
*/
@@ -3371,23 +3368,16 @@ TclCleanupStackForBreakContinue(
int toPop = envPtr->expandCount - auxPtr->expandTarget;
if (toPop > 0) {
- while (toPop > 0) {
+ while (toPop --> 0) {
TclEmitOpcode(INST_EXPAND_DROP, envPtr);
- toPop--;
}
TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth,
envPtr);
- toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth;
- while (toPop > 0) {
- TclEmitOpcode(INST_POP, envPtr);
- toPop--;
- }
- } else {
- toPop = envPtr->currStackDepth - auxPtr->stackDepth;
- while (toPop > 0) {
- TclEmitOpcode(INST_POP, envPtr);
- toPop--;
- }
+ envPtr->currStackDepth = auxPtr->expandTargetDepth;
+ }
+ toPop = envPtr->currStackDepth - auxPtr->stackDepth;
+ while (toPop --> 0) {
+ TclEmitOpcode(INST_POP, envPtr);
}
envPtr->currStackDepth = savedStackDepth;
}
@@ -3904,6 +3894,193 @@ TclFixupForwardJump(
/*
*----------------------------------------------------------------------
*
+ * TclEmitInvoke --
+ *
+ * Emit one of the invoke-related instructions, wrapping it if necessary
+ * in code that ensures that any break or continue operation passing
+ * through it gets the stack unwinding correct, converting it into an
+ * internal jump if in an appropriate context.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Issues the jump with all correct stack management. May create another
+ * loop exception range; pointers to ExceptionRange and ExceptionAux
+ * structures should not be held across this call.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclEmitInvoke(
+ CompileEnv *envPtr,
+ int opcode,
+ ...)
+{
+ va_list argList;
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxBreakPtr, *auxContinuePtr;
+ int arg1, arg2, wordCount = 0, expandCount = 0;
+ int loopRange = 0, breakRange = 0, continueRange = 0;
+
+ /*
+ * Parse the arguments.
+ */
+
+ va_start(argList, opcode);
+ switch (opcode) {
+ case INST_INVOKE_STK1:
+ wordCount = arg1 = va_arg(argList, int);
+ arg2 = 0;
+ break;
+ case INST_INVOKE_STK4:
+ wordCount = arg1 = va_arg(argList, int);
+ arg2 = 0;
+ break;
+ case INST_INVOKE_REPLACE:
+ arg1 = va_arg(argList, int);
+ arg2 = va_arg(argList, int);
+ wordCount = arg1 + arg2 - 1;
+ break;
+ default:
+ Tcl_Panic("unexpected opcode");
+ case INST_EVAL_STK:
+ wordCount = 1;
+ arg1 = arg2 = 0;
+ break;
+ case INST_RETURN_STK:
+ wordCount = 2;
+ arg1 = arg2 = 0;
+ break;
+ case INST_INVOKE_EXPANDED:
+ wordCount = arg1 = va_arg(argList, int);
+ arg2 = 0;
+ expandCount = 1;
+ break;
+ }
+ va_end(argList);
+
+ /*
+ * Determine if we need to handle break and continue exceptions with a
+ * special handling exception range (so that we can correctly unwind the
+ * stack).
+ *
+ * These must be done separately; they can be different (especially for
+ * calls from inside a [for] increment clause).
+ */
+
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr);
+ if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
+ auxBreakPtr = NULL;
+ } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount
+ && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) {
+ auxBreakPtr = NULL;
+ } else {
+ breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
+ }
+
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
+ &auxContinuePtr);
+ if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
+ auxContinuePtr = NULL;
+ } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
+ && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) {
+ auxContinuePtr = NULL;
+ } else {
+ continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
+ }
+
+ if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
+ loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ ExceptionRangeStarts(envPtr, loopRange);
+ }
+
+ /*
+ * Issue the invoke itself.
+ */
+
+ switch (opcode) {
+ case INST_INVOKE_STK1:
+ TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr);
+ break;
+ case INST_INVOKE_STK4:
+ TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr);
+ break;
+ case INST_INVOKE_EXPANDED:
+ TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
+ envPtr->expandCount--;
+ TclAdjustStackDepth(1 - arg1, envPtr);
+ break;
+ case INST_EVAL_STK:
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ break;
+ case INST_RETURN_STK:
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ break;
+ case INST_INVOKE_REPLACE:
+ TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr);
+ TclEmitInt1(arg2, envPtr);
+ TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */
+ break;
+ }
+
+ /*
+ * If we're generating a special wrapper exception range, we need to
+ * finish that up now.
+ */
+
+ if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
+ int savedStackDepth = envPtr->currStackDepth;
+ int savedExpandCount = envPtr->expandCount;
+ JumpFixup nonTrapFixup;
+
+ if (auxBreakPtr != NULL) {
+ auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange;
+ }
+ if (auxContinuePtr != NULL) {
+ auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange;
+ }
+
+ ExceptionRangeEnds(envPtr, loopRange);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup);
+
+ /*
+ * Careful! When generating these stack unwinding sequences, the depth
+ * of stack in the cases where they are taken is not the same as if
+ * the exception is not taken.
+ */
+
+ if (auxBreakPtr != NULL) {
+ TclAdjustStackDepth(-1, envPtr);
+
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclCleanupStackForBreakContinue(envPtr, auxBreakPtr);
+ TclAddLoopBreakFixup(envPtr, auxBreakPtr);
+
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->expandCount = savedExpandCount;
+ }
+
+ if (auxContinuePtr != NULL) {
+ TclAdjustStackDepth(-1, envPtr);
+
+ ExceptionRangeTarget(envPtr, loopRange, continueOffset);
+ TclCleanupStackForBreakContinue(envPtr, auxContinuePtr);
+ TclAddLoopContinueFixup(envPtr, auxContinuePtr);
+
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->expandCount = savedExpandCount;
+ }
+
+ TclFinalizeLoopExceptionRange(envPtr, loopRange);
+ TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclGetInstructionTable --
*
* Returns a pointer to the table describing Tcl bytecode instructions.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c42f79d..1f144b0 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1021,6 +1021,7 @@ MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr);
+MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...);
MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index d1a788f..c71fad0 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3179,9 +3179,7 @@ CompileToInvokedCommand(
* Do the replacing dispatch.
*/
- TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
- TclEmitInt1(numWords+1, envPtr);
- TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */
+ TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);
}
/*
diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
index b7f4173..3b16e6e 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -344,21 +344,28 @@ AdvanceJumps(
CompileEnv *envPtr)
{
unsigned char *currentInstPtr;
+ Tcl_HashTable jumps;
for (currentInstPtr = envPtr->codeStart ;
currentInstPtr < envPtr->codeNext-1 ;
currentInstPtr += AddrLength(currentInstPtr)) {
- int offset, delta;
+ int offset, delta, isNew;
switch (*currentInstPtr) {
case INST_JUMP1:
case INST_JUMP_TRUE1:
case INST_JUMP_FALSE1:
offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
for (delta=0 ; offset+delta != 0 ;) {
if (offset + delta < -128 || offset + delta > 127) {
break;
}
+ Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
+ if (!isNew) {
+ offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ break;
+ }
offset += delta;
switch (*(currentInstPtr + offset)) {
case INST_NOP:
@@ -373,13 +380,21 @@ AdvanceJumps(
}
break;
}
+ Tcl_DeleteHashTable(&jumps);
TclStoreInt1AtPtr(offset, currentInstPtr + 1);
continue;
case INST_JUMP4:
case INST_JUMP_TRUE4:
case INST_JUMP_FALSE4:
+ Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
+ Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew);
for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
+ Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
+ if (!isNew) {
+ offset = TclGetInt4AtPtr(currentInstPtr + 1);
+ break;
+ }
switch (*(currentInstPtr + offset)) {
case INST_NOP:
offset += InstLength(INST_NOP);
@@ -393,6 +408,7 @@ AdvanceJumps(
}
break;
}
+ Tcl_DeleteHashTable(&jumps);
TclStoreInt4AtPtr(offset, currentInstPtr + 1);
continue;
}
diff --git a/generic/tclScan.c b/generic/tclScan.c
index c54395d..ec54ddb 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -406,11 +406,14 @@ ValidateFormat(
*/
case 'd':
case 'e':
+ case 'E':
case 'f':
case 'g':
+ case 'G':
case 'i':
case 'o':
case 'x':
+ case 'X':
case 'b':
break;
case 'u':
@@ -743,6 +746,7 @@ Tcl_ScanObjCmd(
parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
break;
case 'x':
+ case 'X':
op = 'i';
parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
break;
@@ -758,7 +762,9 @@ Tcl_ScanObjCmd(
case 'f':
case 'e':
+ case 'E':
case 'g':
+ case 'G':
op = 'f';
break;
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 6550978..160342f 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.8.7
+package provide http 2.8.8
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -113,7 +113,7 @@ if {[info command http::Log] eq {}} {proc http::Log {args} {}}
proc http::register {proto port command} {
variable urlTypes
- set urlTypes($proto) [list $port $command]
+ set urlTypes([string tolower $proto]) [list $port $command]
}
# http::unregister --
@@ -127,11 +127,12 @@ proc http::register {proto port command} {
proc http::unregister {proto} {
variable urlTypes
- if {![info exists urlTypes($proto)]} {
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
return -code error "unsupported url type \"$proto\""
}
- set old $urlTypes($proto)
- unset urlTypes($proto)
+ set old $urlTypes($lower)
+ unset urlTypes($lower)
return $old
}
@@ -514,12 +515,13 @@ proc http::geturl {url args} {
if {$proto eq ""} {
set proto http
}
- if {![info exists urlTypes($proto)]} {
+ set lower [string tolower $proto]
+ if {![info exists urlTypes($lower)]} {
unset $token
return -code error "Unsupported URL type \"$proto\""
}
- set defport [lindex $urlTypes($proto) 0]
- set defcmd [lindex $urlTypes($proto) 1]
+ set defport [lindex $urlTypes($lower) 0]
+ set defcmd [lindex $urlTypes($lower) 1]
if {$port eq ""} {
set port $defport
@@ -650,7 +652,8 @@ proc http::Connected { token proto phost srvurl} {
set host [lindex [split $state(socketinfo) :] 0]
set port [lindex [split $state(socketinfo) :] 1]
- set defport [lindex $urlTypes($proto) 0]
+ set lower [string tolower $proto]
+ set defport [lindex $urlTypes($lower) 0]
# Send data in cr-lf format, but accept any line terminators
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index e485046..4a03a53 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
-package ifneeded http 2.8.7 [list tclPkgSetup $dir http 2.8.7 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.8.8 [list tclPkgSetup $dir http 2.8.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/tests/compile.test b/tests/compile.test
index ae1ddc7..d46faef 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -713,6 +713,70 @@ test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *
+test compile-20.1 {ensure there are no infinite loops in optimizing} {
+ tcl::unsupported::disassemble script {
+ while 1 {
+ return -code continue -level 0
+ }
+ }
+ return
+} {}
+test compile-20.2 {ensure there are no infinite loops in optimizing} {
+ tcl::unsupported::disassemble script {
+ while 1 {
+ while 1 {
+ return -code break -level 0
+ }
+ }
+ }
+ return
+} {}
+
+test compile-21.1 {stack balance management} {
+ apply {{} {
+ set result {}
+ while 1 {
+ lappend result a
+ lappend result [list b [break]]
+ lappend result c
+ }
+ return $result
+ }}
+} a
+test compile-21.2 {stack balance management} {
+ apply {{} {
+ set result {}
+ while {[incr i] <= 10} {
+ lappend result $i
+ lappend result [list b [continue] c]
+ lappend result c
+ }
+ return $result
+ }}
+} {1 2 3 4 5 6 7 8 9 10}
+test compile-21.3 {stack balance management} {
+ apply {args {
+ set result {}
+ while 1 {
+ lappend result a
+ lappend result [concat {*}$args [break]]
+ lappend result c
+ }
+ return $result
+ }} P Q R S T
+} a
+test compile-21.4 {stack balance management} {
+ apply {args {
+ set result {}
+ while {[incr i] <= 10} {
+ lappend result $i
+ lappend result [concat {*}$args [continue] c]
+ lappend result c
+ }
+ return $result
+ }} P Q R S T
+} {1 2 3 4 5 6 7 8 9 10}
+
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
# cleanup
diff --git a/tests/for.test b/tests/for.test
index 8936682..8abd270 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -942,6 +942,248 @@ test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount}
expr {$end - $tmp}
}}
} 0
+test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [apply {{} {return -code break}}] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [apply {{} {return -code continue}}] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[apply {{} {
+ return -code continue
+ }}] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code break
+ }}] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code continue
+ }}] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code break
+ }}] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code continue
+ }}] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [{*}$op] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [{*}$op] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
+test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[{*}$op] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[{*}$op] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
+test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
+test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
# cleanup
::tcltest::cleanupTests
diff --git a/tests/http.test b/tests/http.test
index 7d439b1..a52cfb1 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -119,7 +119,7 @@ test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //[info hostname]:$port
-set badurl //[info hostname]:6666
+set badurl //[info hostname]:[expr $port+1]
test http-3.3 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -131,7 +131,7 @@ test http-3.3 {http::geturl} -body {
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
-set fullurl http://user:pass@[info hostname]:$port/a/b/c
+set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
diff --git a/tests/scan.test b/tests/scan.test
index ea0c500..b57b641 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -375,6 +375,12 @@ test scan-4.48 {Tcl_ScanObjCmd, float scanning} {
test scan-4.49 {Tcl_ScanObjCmd, float scanning} {
list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z
} {3 0.1 0.2 3.0}
+test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} {
+ list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z
+} {3 0.5 42 0.75}
+test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} {
+ list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z
+} {3 0.5 42 0.75}
test scan-4.50 {Tcl_ScanObjCmd, float scanning} {
list [scan {1234567890a} %f x] $x
} {1 1234567890.0}
@@ -450,6 +456,9 @@ test scan-4.63 {scanning of large and negative hex integers} {
list [scan $scanstring {%x %x %x} a b c] \
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
+test scan-4.64 {scanning of hex with %X} {
+ scan "123 abc f78" %X%X%X
+} {291 2748 3960}
test scan-5.1 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
@@ -626,14 +635,14 @@ test scan-8.4 {error conditions} -returnCodes error -body {
scan a %O x
} -result {bad scan conversion character "O"}
test scan-8.5 {error conditions} -returnCodes error -body {
- scan a %X x
-} -result {bad scan conversion character "X"}
+ scan a %B x
+} -result {bad scan conversion character "B"}
test scan-8.6 {error conditions} -returnCodes error -body {
scan a %F x
} -result {bad scan conversion character "F"}
test scan-8.7 {error conditions} -returnCodes error -body {
- scan a %E x
-} -result {bad scan conversion character "E"}
+ scan a %p x
+} -result {bad scan conversion character "p"}
test scan-8.8 {error conditions} -returnCodes error -body {
scan a "%d %d" a
} -result {different numbers of variable names and field specifiers}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 67bbd49..2634f50 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -839,8 +839,8 @@ install-libraries: libraries
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \
done;
- @echo "Installing package http 2.8.7 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.7.tm;
+ @echo "Installing package http 2.8.8 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.8.tm;
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
@for i in $(TOP_DIR)/library/opt/*.tcl ; \
do \
diff --git a/win/Makefile.in b/win/Makefile.in
index 6f27856..0051c8b 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -637,8 +637,8 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
done;
- @echo "Installing package http 2.8.7 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.7.tm;
+ @echo "Installing package http 2.8.8 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.8.tm;
@echo "Installing library opt0.4 directory";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
generated by cgit v0.12 at 2024-11-24 21:13:58 (GMT)