Fix [Bug 2568434]

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