The [switch] command is now bytecode compiled, at least in the most common

case.  There's room for improvement in the future, of course.  [Patch #644819]
Also adds another macro to help with jump offset fixups.

1 files changed, 129 insertions, 1 deletions

diff --git a/tests/switch.test b/tests/switch.test
index f1ae7c7..153557f 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -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: switch.test,v 1.7 2001/11/27 13:30:54 dkf Exp $
+# RCS: @(#) $Id: switch.test,v 1.8 2003/03/05 22:31:24 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -213,6 +213,134 @@ test switch-9.10 {unpaired pattern} {
     list [catch {switch x {a {} x {} # comment b}} msg] $msg
 } {1 {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation}}
 
+test switch-10.1 {compiled -exact switch} {
+    if 1 {switch -exact -- a {a {format 1} b {format 2}}}
+} 1
+test switch-10.2 {compiled -exact switch} {
+    if 1 {switch -exact -- b {a {format 1} b {format 2}}}
+} 2
+test switch-10.3 {compiled -exact switch} {
+    if 1 {switch -exact -- c {a {format 1} b {format 2}}}
+} {}
+test switch-10.4 {compiled -exact switch} {
+    if 1 {
+	set x 0
+	switch -exact -- c {a {format 1} b {format 2}}
+    }
+} {}
+test switch-10.5 {compiled -exact switch} {
+    if 1 {switch -exact -- a {a - aa {format 1} b {format 2}}}
+} 1
+test switch-10.6 {compiled -exact switch} {
+    if 1 {switch -exact -- b {a {
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+	set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1
+    } b {format 2}}}
+} 2
+
+# Command variants are:
+#    c* are compiled switches, i* are interpreted
+#    *-glob use glob matching, *-exact use exact matching
+#    *2* include a default clause (different results too.)
+proc cswtest-glob s {
+    set x 0; set y 0
+    foreach c [split $s {}] {
+	switch -glob -- $c {
+	    a {incr x}
+	    b {incr y}
+	}
+    }
+    return $x,$y
+}
+proc iswtest-glob s {
+    set x 0; set y 0
+    foreach c [split $s {}] {
+	switch -glob -- $c a {incr x} b {incr y}
+    }
+    return $x,$y
+}
+proc cswtest-exact s {
+    set x 0; set y 0
+    foreach c [split $s {}] {
+	switch -exact -- $c {
+	    a {incr x}
+	    b {incr y}
+	}
+    }
+    return $x,$y
+}
+proc iswtest-exact s {
+    set x 0; set y 0
+    foreach c [split $s {}] {
+	switch -exact -- $c a {incr x} b {incr y}
+    }
+    return $x,$y
+}
+proc cswtest2-glob s {
+    set x 0; set y 0; set z 0
+    foreach c [split $s {}] {
+	switch -glob -- $c {
+	    a {incr x}
+	    b {incr y}
+	    default {incr z}
+	}
+    }
+    return $x,$y,$z
+}
+proc iswtest2-glob s {
+    set x 0; set y 0; set z 0
+    foreach c [split $s {}] {
+	switch -glob -- $c a {incr x} b {incr y} default {incr z}
+    }
+    return $x,$y,$z
+}
+proc cswtest2-exact s {
+    set x 0; set y 0; set z 0
+    foreach c [split $s {}] {
+	switch -exact -- $c {
+	    a {incr x}
+	    b {incr y}
+	    default {incr z}
+	}
+    }
+    return $x,$y,$z
+}
+proc iswtest2-exact s {
+    set x 0; set y 0; set z 0
+    foreach c [split $s {}] {
+	switch -exact -- $c a {incr x} b {incr y} default {incr z}
+    }
+    return $x,$y,$z
+}
+
+test switch-10.7 {comparison of compiled and interpreted behaviour of switch, exact matching} {
+    expr {[cswtest-exact abcb] eq [iswtest-exact abcb]}
+} 1
+test switch-10.8 {comparison of compiled and interpreted behaviour of switch, glob matching} {
+    expr {[cswtest-glob abcb] eq [iswtest-glob abcb]}
+} 1
+test switch-10.9 {comparison of compiled and interpreted behaviour of switch, exact matching with default} {
+    expr {[cswtest2-exact abcb] eq [iswtest2-exact abcb]}
+} 1
+test switch-10.10 {comparison of compiled and interpreted behaviour of switch, glob matching with default} {
+    expr {[cswtest2-glob abcb] eq [iswtest2-glob abcb]}
+} 1
+
+rename cswtest-glob {}
+rename iswtest-glob {}
+rename cswtest2-glob {}
+rename iswtest2-glob {}
+rename cswtest-exact {}
+rename iswtest-exact {}
+rename cswtest2-exact {}
+rename iswtest2-exact {}
+
 # cleanup
 ::tcltest::cleanupTests
 return