summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-02-05 14:21:42 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-02-05 14:21:42 (GMT)
commitcd89b9ea6457cd428033dbb8b2f7746dd35222ed (patch)
tree596004a17d20a96f3f29775c6400a59cd9c7c043
parent7933720835766c9a797749bd47fd1501ae6871d2 (diff)
downloadtcl-cd89b9ea6457cd428033dbb8b2f7746dd35222ed.zip
tcl-cd89b9ea6457cd428033dbb8b2f7746dd35222ed.tar.gz
tcl-cd89b9ea6457cd428033dbb8b2f7746dd35222ed.tar.bz2
Fix [Bug 2568434]
-rw-r--r--ChangeLog3
-rw-r--r--generic/tclExecute.c8
-rw-r--r--tests/execute.test68
3 files changed, 39 insertions, 40 deletions
diff --git a/ChangeLog b/ChangeLog
index 265120d..3d3710b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
2009-02-05 Donal K. Fellows <dkf@users.sf.net>
+ * generic/tclExecute.c (TclExecuteByteCode): Make sure that
+ INST_CONCAT1 will not lose string reps wrongly. [Bug 2568434]
+
* generic/tclStringObj.c (Tcl_AppendObjToObj): Special-case the
appending of one bytearray to another, which can be extremely rapid.
Part of scheme to address [Bug 1665628] by making the basic string
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d1c29eb..601fe6e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.424 2009/01/09 11:21:45 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.425 2009/02/05 14:21:42 dkf Exp $
*/
#include "tclInt.h"
@@ -2448,7 +2448,7 @@ TclExecuteByteCode(
opnd = TclGetUInt1AtPtr(pc+1);
/*
- * Detect only-bytearray-or-null case
+ * Detect only-bytearray-or-null case.
*/
for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
@@ -2456,6 +2456,10 @@ TclExecuteByteCode(
&& ((*currPtr)->bytes != tclEmptyStringRep)) {
onlyb = 0;
break;
+ } else if (((*currPtr)->typePtr == &tclByteArrayType) &&
+ ((*currPtr)->bytes != NULL)) {
+ onlyb = 0;
+ break;
}
}
diff --git a/tests/execute.test b/tests/execute.test
index d9f02e0..f6174d0 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -14,7 +14,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: execute.test,v 1.29 2008/08/05 15:52:24 msofer Exp $
+# RCS: @(#) $Id: execute.test,v 1.30 2009/02/05 14:21:43 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -43,14 +43,12 @@ testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# INST_PUSH4 not tested
# INST_POP not tested
# INST_DUP not tested
-# INST_CONCAT1 not tested
# INST_INVOKE_STK4 not tested
# INST_INVOKE_STK1 not tested
# INST_EVAL_STK not tested
# INST_EXPR_STK not tested
# INST_LOAD_SCALAR1
-
test execute-1.1 {TclExecuteByteCode, INST_LOAD_SCALAR1, small opnd} {
proc foo {} {
set x 1
@@ -68,7 +66,6 @@ test execute-1.2 {TclExecuteByteCode, INST_LOAD_SCALAR1, large opnd} {
set y 1
return $y
}
-
proc foo {} $body
foo
} 1
@@ -81,9 +78,7 @@ test execute-1.3 {TclExecuteByteCode, INST_LOAD_SCALAR1, error} {
list [catch {foo} msg] $msg
} {1 {can't read "x": no such variable}}
-
# INST_LOAD_SCALAR4
-
test execute-2.1 {TclExecuteByteCode, INST_LOAD_SCALAR4, simple case} {
set body {}
for {set i 0} {$i < 256} {incr i} {
@@ -93,7 +88,6 @@ test execute-2.1 {TclExecuteByteCode, INST_LOAD_SCALAR4, simple case} {
set y 1
return $y
}
-
proc foo {} $body
foo
} 1
@@ -107,12 +101,10 @@ test execute-2.2 {TclExecuteByteCode, INST_LOAD_SCALAR4, error} {
unset y
return $y
}
-
proc foo {} $body
list [catch {foo} msg] $msg
} {1 {can't read "y": no such variable}}
-
# INST_LOAD_SCALAR_STK not tested
# INST_LOAD_ARRAY4 not tested
# INST_LOAD_ARRAY1 not tested
@@ -900,43 +892,40 @@ test execute-8.1 {Stack protection} -setup {
trace remove variable ::errorInfo {write unset} whatever
rename whatever {}
} -returnCodes error -match glob -result *
-
test execute-8.2 {Stack restoration} -body {
# Test for [Bug #816641], correct restoration
# of the stack top after the stack is grown
- proc f {args} { f bee bop }
- catch f msg
- set msg
- } -setup {
+ proc f {args} { f bee bop }
+ catch f msg
+ set msg
+} -setup {
# Avoid crashes when system stack size is limited (thread-enabled!)
- set limit [interp recursionlimit {}]
- interp recursionlimit {} 100
- } -cleanup {
- interp recursionlimit {} $limit
- } -result {too many nested evaluations (infinite loop?)}
-
+ set limit [interp recursionlimit {}]
+ interp recursionlimit {} 100
+} -cleanup {
+ interp recursionlimit {} $limit
+} -result {too many nested evaluations (infinite loop?)}
test execute-8.3 {Stack restoration} -body {
# Test for [Bug #1055676], correct restoration
# of the stack top after the epoch is bumped and
# the stack is grown in a call from a nested evaluation
- set arglst [string repeat "a " 1000]
- proc f {args} "f $arglst"
- proc run {} {
- # bump the interp's epoch
- rename ::set ::dummy
- rename ::dummy ::set
- catch f msg
- set msg
- }
- run
- } -setup {
+ set arglst [string repeat "a " 1000]
+ proc f {args} "f $arglst"
+ proc run {} {
+ # bump the interp's epoch
+ rename ::set ::dummy
+ rename ::dummy ::set
+ catch f msg
+ set msg
+ }
+ run
+} -setup {
# Avoid crashes when system stack size is limited (thread-enabled!)
- set limit [interp recursionlimit {}]
- interp recursionlimit {} 100
- } -cleanup {
- interp recursionlimit {} $limit
- } -result {too many nested evaluations (infinite loop?)}
-
+ set limit [interp recursionlimit {}]
+ interp recursionlimit {} 100
+} -cleanup {
+ interp recursionlimit {} $limit
+} -result {too many nested evaluations (infinite loop?)}
test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
proc foo {} {
error bar
@@ -957,7 +946,6 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
rename foo {}
rename FOO {}
} -result {}
-
test execute-8.5 {Bug 2038069} -setup {
proc demo {} {
catch [list error FOO] m o
@@ -987,6 +975,10 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} {
set result
} SUCCESS
+test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
+ apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130
+} {48 {304 304}}
+
# cleanup
if {[info commands testobj] != {}} {
testobj freeallvars