* generic/tclCmdAH.c (Tcl_ForObjCmd): Fixed crash caused by

failure to reset the result before evaluating the test
expression.

3 files changed, 86 insertions, 74 deletions

diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 8aa6880..3956766 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdAH.c,v 1.5 1999/04/16 00:46:43 stanton Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.5.2.1 1999/05/14 22:18:05 stanton Exp $
  */
 
 #include "tclInt.h"
@@ -1517,7 +1517,7 @@ GetTypeFromMode(mode)
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_FoObjCmd --
+ * Tcl_ForObjCmd --
  *
  *      This procedure is invoked to process the "for" Tcl command.
  *      See the user documentation for details on what it does.
@@ -1559,6 +1559,13 @@ Tcl_ForObjCmd(dummy, interp, objc, objv)
         return result;
     }
     while (1) {
+	/*
+	 * We need to reset the result before passing it off to
+	 * Tcl_ExprBooleanObj.  Otherwise, any error message will be appended
+	 * to the result of the last evaluation.
+	 */
+
+	Tcl_ResetResult(interp);
         result = Tcl_ExprBooleanObj(interp, objv[2], &value);
         if (result != TCL_OK) {
             return result;
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 19ef9c4..611470f 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: cmdAH.test,v 1.5 1999/04/16 00:47:24 stanton Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.5.2.1 1999/05/14 22:18:06 stanton Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -1431,28 +1431,28 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} {
 
 # Error conditions
 
-test cmdAH-30.1 {error conditions} {
+test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
     list [catch {file gorp x} msg] $msg
 } {1 {bad option "gorp": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.2 {error conditions} {
+test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
     list [catch {file ex x} msg] $msg
 } {1 {ambiguous option "ex": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.3 {error conditions} {
+test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
     list [catch {file is x} msg] $msg
 } {1 {ambiguous option "is": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.4 {error conditions} {
+test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
     list [catch {file z x} msg] $msg
 } {1 {bad option "z": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.5 {error conditions} {
+test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
     list [catch {file read x} msg] $msg
 } {1 {ambiguous option "read": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.6 {error conditions} {
+test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
     list [catch {file s x} msg] $msg
 } {1 {ambiguous option "s": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.7 {error conditions} {
+test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
     list [catch {file t x} msg] $msg
 } {1 {ambiguous option "t": must be atime, attributes, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
-test cmdAH-30.8 {error conditions} {
+test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
     list [catch {file dirname ~woohgy} msg] $msg
 } {1 {user "woohgy" doesn't exist}}
 
@@ -1460,6 +1460,8 @@ test cmdAH-30.8 {error conditions} {
 catch {testsetplatform $platform}
 catch {unset platform}
 
+# Tcl_ForObjCmd is tested in for.test
+
 catch {exec chmod 777 dir.file}
 file delete -force dir.file
 file delete gorp.file
diff --git a/tests/for.test b/tests/for.test
index 4503c0b..05d1500 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: for.test,v 1.3 1999/04/16 00:47:27 stanton Exp $
+# RCS: @(#) $Id: for.test,v 1.3.2.1 1999/05/14 22:18:06 stanton Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -584,45 +584,77 @@ test for-4.1 {break must reset the interp result} {
     set j
 } {}
 
-# Basic "for" operation with computed command names.
-test for-5.1 {for cmd with computed command names: missing initial command} {
-    set z for
-    list [catch {$z} msg] $msg
-} {1 {wrong # args: should be "for start test next command"}}
-test for-5.2 {for cmd with computed command names: error in initial command} {
+# Test for incorrect "double evaluation" semantics
+
+test for-5.1 {possible delayed substitution of increment command} {knownBug} {
+    # Increment should be 5, and lappend should always append 5
+    catch {unset a}
+    catch {unset i}
+    set a 5
+    set i {}
+    for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
+    set i
+} {1 6 11}
+
+test for-5.2 {possible delayed substitution of body command} {knownBug} {
+    # Increment should be 5, and lappend should always append 5
+    set a 5
+    set i {}
+    for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
+    set i
+} {5 5 5 5}
+
+# In the following tests we need to bypass the bytecode compiler by
+# substituting the command from a variable.  This ensures that command
+# procedure is invoked directly.
+
+test for-6.1 {Tcl_ForObjCmd: number of args} {
     set z for
-    list [catch {$z {set}} msg] $msg $errorInfo
-} {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command"
-    while executing
-"$z {set}"}}
-test for-5.3 {for cmd with computed command names: missing test expression} {
+    catch {$z} msg
+    set msg
+} {wrong # args: should be "for start test next command"}
+test for-6.2 {Tcl_ForObjCmd: number of args} {
     set z for
     catch {$z {set i 0}} msg
     set msg
 } {wrong # args: should be "for start test next command"}
-test for-5.4 {for cmd with computed command names: error in test expression} {
-    set z for
-    catch {$z {set i 0} {$i<}} msg
-    set errorInfo
-} {wrong # args: should be "for start test next command"
-    while executing
-"$z {set i 0} {$i<}"}
-test for-5.5 {for cmd with computed command names: test expression is enclosed in quotes} {
-    set z for
-    set i 0
-    $z {} "$i > 5" {incr i} {}
-} {}
-test for-5.6 {for cmd with computed command names: missing "next" command} {
+test for-6.3 {Tcl_ForObjCmd: number of args} {
     set z for
     catch {$z {set i 0} {$i < 5}} msg
     set msg
 } {wrong # args: should be "for start test next command"}
-test for-5.7 {for cmd with computed command names: missing command body} {
+test for-6.4 {Tcl_ForObjCmd: number of args} {
     set z for
     catch {$z {set i 0} {$i < 5} {incr i}} msg
     set msg
 } {wrong # args: should be "for start test next command"}
-test for-5.8 {for cmd with computed command names: error executing command body} {
+test for-6.5 {Tcl_ForObjCmd: number of args} {
+    set z for
+    catch {$z {set i 0} {$i < 5} {incr i} {body} extra} msg
+    set msg
+} {wrong # args: should be "for start test next command"}
+test for-6.6 {Tcl_ForObjCmd: error in initial command} {
+    set z for
+    list [catch {$z {set} {$i < 5} {incr i} {body}} msg] $msg $errorInfo
+} {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?"
+    while compiling
+"set"
+    ("for" initial command)
+    invoked from within
+"$z {set} {$i < 5} {incr i} {body}"}}
+test for-6.7 {Tcl_ForObjCmd: error in test expression} {
+    set z for
+    list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo
+} {1 {syntax error in expression "i < 5"} {syntax error in expression "i < 5"
+    while executing
+"$z {set i 0} {i < 5} {incr i} {body}"}}
+test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
+    set z for
+    set i 0
+    $z {set i 6} "$i > 5" {incr i} {set y $i}
+    set i
+} 6
+test for-6.9 {Tcl_ForObjCmd: error executing command body} {
     set z for
     catch {$z {set i 0} {$i < 5} {incr i} {set}} msg
     set errorInfo
@@ -632,7 +664,7 @@ test for-5.8 {for cmd with computed command names: error executing command body}
     ("for" body line 1)
     invoked from within
 "$z {set i 0} {$i < 5} {incr i} {set}"}
-test for-5.9 {for cmd with computed command names: simple command body} {
+test for-6.10 {Tcl_ForObjCmd: simple command body} {
     set z for
     set a {}
     $z {set i 1} {$i<6} {set i [expr $i+1]} {
@@ -641,13 +673,13 @@ test for-5.9 {for cmd with computed command names: simple command body} {
     }
     set a
 } {1 2 3}
-test for-5.10 {for cmd with computed command names: command body in quotes} {
+test for-6.11 {Tcl_ForObjCmd: command body in quotes} {
     set z for
     set a {}
     $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x"
     set a
 } {xxxxx}
-test for-5.11 {for cmd with computed command names: computed command body} {
+test for-6.12 {Tcl_ForObjCmd: computed command body} {
     set z for
     catch {unset x1}
     catch {unset bb}
@@ -659,7 +691,7 @@ test for-5.11 {for cmd with computed command names: computed command body} {
     $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2
     set a
 } {x1}
-test for-5.12 {for cmd with computed command names: error in "next" command} {
+test for-6.13 {Tcl_ForObjCmd: error in "next" command} {
     set z for
     catch {$z {set i 0} {$i < 5} {set} {set j 4}} msg
     set errorInfo
@@ -669,7 +701,7 @@ test for-5.12 {for cmd with computed command names: error in "next" command} {
     ("for" loop-end command)
     invoked from within
 "$z {set i 0} {$i < 5} {set} {set j 4}"}
-test for-5.13 {for cmd with computed command names: long command body} {
+test for-6.14 {Tcl_ForObjCmd: long command body} {
     set z for
     set a {}
     $z {set i 1} {$i<6} {set i [expr $i+1]} {
@@ -704,49 +736,20 @@ test for-5.13 {for cmd with computed command names: long command body} {
     }
     set a
 } {1 2 3}
-test for-5.14 {for cmd with computed command names: for command result} {
+test for-6.15 {Tcl_ForObjCmd: for command result} {
     set z for
     set a [$z {set i 0} {$i < 5} {incr i} {}]
     set a
 } {}
-test for-5.15 {for cmd with computed command names: for command result} {
+test for-6.16 {Tcl_ForObjCmd: for command result} {
     set z for
     set a [$z {set i 0} {$i < 5} {incr i} {if $i==3 break}]
     set a
 } {}
 
-# Test for incorrect "double evaluation" semantics
 
-test for-6.1 {possible delayed substitution of increment command} {knownBug} {
-    # Increment should be 5, and lappend should always append 5
-    catch {unset a}
-    catch {unset i}
-    set a 5
-    set i {}
-    for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
-    set i
-} {1 6 11}
-
-test for-6.2 {possible delayed substitution of body command} {knownBug} {
-    # Increment should be 5, and lappend should always append 5
-    set a 5
-    set i {}
-    for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
-    set i
-} {5 5 5 5}
 
 # cleanup
 ::tcltest::cleanupTests
 return
 
-
-
-
-
-
-
-
-
-
-
-