christoph/fail
1
Fork 0
Code Actions Packages Releases Activity

debuggers: import openocd-0.7.0

Browse Source 
Initial check-in of openocd-0.7.0 as it can be downloaded from
http://sourceforge.net/projects/openocd/files/openocd/0.7.0/

Any modifications will follow.

Change-Id: I6949beaefd589e046395ea0cb80f4e1ab1654d55
This commit is contained in:
Lars Rademacher
2013-10-21 00:50:02 +02:00
parent 85fffe007e
commit 83d72a091e
1148 changed files with 571445 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

247
debuggers/openocd/jimtcl/tests/alias.test Normal file
View File

@ -0,0 +1,247 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd array
needs cmd ref
test alias-1.1 "One word alias" {
set x 2
alias newincr incr
newincr x
} {3}
test alias-1.4 "Two word alias" {
alias infoexists info exists
infoexists x
} {1}
test alias-1.5 "Replace alias" {
alias newincr infoexists
newincr x
} {1}
test alias-1.6 "Delete alias" {
rename newincr ""
catch {newincr x}
} {1}
test alias-1.7 "Replace alias with proc" {
proc infoexists {n} {
return yes
}
infoexists any
} {yes}
test alias-1.8 "Replace proc with alias" {
alias infoexists info exists
infoexists any
} {0}
test alias-1.9 "error message from alias" -body {
alias newstring string
newstring match
} -returnCodes error -result {wrong # args: should be "string match ?-nocase? pattern string"}
test alias-1.10 "info alias" {
alias x info exists
info alias x
} {info exists}
test alias-1.10 "info alias on non-alias" -body {
info alias format
} -returnCodes error -result {command "format" is not an alias}
test curry-1.1 "One word curry" {
set x 2
set one [curry incr]
$one x
} {3}
test curry-1.4 "Two word curry" {
set two [curry info exists]
list [$two x] [$two y]
} {1 0}
test curry-1.5 "Delete curry" {
unset one two
collect
} {2}
test local-1.2 "local curry in proc" {
proc a {} {
local set p [curry info exists]
set x 1
list $p [$p x] [$p y]
}
lassign [a] p exists_x exists_y
list [info procs $p] $exists_x $exists_y
} {{} 1 0}
test local-1.2 "set local curry in proc" {
proc a {} {
set p [local curry info exists]
set x 1
list $p [$p x] [$p y]
}
lassign [a] p exists_x exists_y
list [info procs $p] $exists_x $exists_y
} {{} 1 0}
test local-1.3 "local alias in proc" {
proc a {} {
local alias p info exists
set x 1
list [p x] [p y]
}
lassign [a] exists_x exists_y
list [info commands p] $exists_x $exists_y
} {{} 1 0}
test local-1.5 "local proc in proc" {
set ::x 1
proc a {} {
local proc b {} { incr ::x }
b
set ::x
}
a
list [info procs b] $::x
} {{} 2}
test local-1.6 "local lambda in lsort" {
proc a {} {
lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
}
a
} {a d f g}
test local-1.7 "check no reference procs" {
info procs "<reference*"
} {}
test local-1.8 "local on non-existent command" {
list [catch {local set x blah} msg] $msg
} {1 {invalid command name "blah"}}
test local-1.9 "local on existing proc" {
proc x {} {
proc a {b} {incr b}
local function a
set c [lambda b {incr b -1}]
local function $c
lappend result [a 1] [$c 2]
}
set result [x]
list [info procs a] $result
} {{} {2 1}}
test statics-1.1 "missing static variable init" {
unset -nocomplain c
catch {
proc a {b} {c} {
# No initialiser for c
}
}
} 1
test statics-1.2 "static variable with invalid name" {
catch {
proc a {b} "{c\0d 4}" {
}
}
} 1
test statics-1.3 "duplicate static variable" {
catch {
proc a {b} {{c 1} {c 2}} {
}
}
} 1
test statics-1.4 "bad static variable init" {
catch {
proc a {b} {{c 1 2}} {
}
}
} 1
test local-2.1 "proc over existing proc" {
proc a {b} {incr b}
proc t {x} {
proc a {b} {incr b -1}
a $x
}
unset -nocomplain x
lappend x [a 5]
lappend x [t 5]
lappend x [a 5]
} {6 4 4}
test local-2.2 "local proc over existing proc" {
proc a {b} {incr b}
proc t {x} {
local proc a {b} {incr b -1}
a $x
}
unset -nocomplain x
lappend x [a 5]
lappend x [t 5]
lappend x [a 5]
} {6 4 6}
test local-2.3 "local proc over existing proc" {
proc a {b} {incr b}
proc t {x} {
local proc a {b} {incr b -1}
a $x
}
unset -nocomplain x
lappend x [a 5]
lappend x [t 5]
lappend x [a 5]
} {6 4 6}
test upcall-1.1 "upcall pushed proc" {
proc a {b} {incr b}
local proc a {b} {
incr b 10
# invoke the original defn via upcall
return [upcall a $b]
}
# Should call the new defn which will call the original defn
a 3
} 14
test upcall-1.2 "upcall in proc" {
proc a {b} {incr b}
proc t {c} {
local proc a {b} {
incr b 10
return [upcall a $b]
}
a $c
}
unset -nocomplain x
lappend x [t 5]
lappend x [a 5]
set x
} {16 6}
test upcall-1.3 "double upcall" {
proc a {} {return 1}
local proc a {} {list 2 {*}[upcall a]}
local proc a {} {list 3 {*}[upcall a]}
a
} {3 2 1}
test upcall-1.4 "upcall errors" {
proc a {} {return 1}
list [catch {upcall a} msg] $msg
} {1 {no previous command: "a"}}
test upcall-1.4 "upcall errors" {
proc a {} {upcall a}
list [catch a msg] $msg
} {1 {no previous command: "a"}}
testreport

136
debuggers/openocd/jimtcl/tests/apply.test Normal file
View File

@ -0,0 +1,136 @@
# Commands covered: apply
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
needs cmd apply
# Tests for wrong number of arguments
test apply-1.1 {too few arguments} -returnCodes error -body {
apply
} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}
# Tests for malformed lambda
test apply-2.0 {malformed lambda} -returnCodes error -body {
set lambda a
apply $lambda
} -result {can't interpret "a" as a lambda expression}
test apply-2.1 {malformed lambda} -returnCodes error -body {
set lambda [list a b c d]
apply $lambda
} -result {can't interpret "a b c d" as a lambda expression}
test apply-2.2 {malformed lambda} -body {
set lambda [list {{}} boo]
apply $lambda
} -returnCodes error -match glob -result {*argument with no name}
test apply-2.3 {malformed lambda} {
set lambda [list {{a b c}} boo]
list [catch {apply $lambda} msg] $msg
} {1 {too many fields in argument specifier "a b c"}}
# Note that Jim allow both of these
test apply-2.4 {malformed lambda} tcl {
set lambda [list a(1) {return $a(1)}]
list [catch {apply $lambda x} msg] $msg
} {1 {formal parameter "a(1)" is an array element}}
test apply-2.5 {malformed lambda} tcl {
set lambda [list a::b {return $a::b}]
list [catch {apply $lambda x} msg] $msg
} {1 {formal parameter "a::b" is not a simple name}}
# Tests for runtime errors in the lambda expression
test apply-4.1 {error in arguments to lambda expression} -body {
set lambda [list x {set x 1}]
apply $lambda
} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
test apply-4.2 {error in arguments to lambda expression} -body {
set lambda [list x {set x 1}]
apply $lambda a b
} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
test apply-5.1 {runtime error in lambda expression} {
set lambda [list {} {error foo}]
list [catch {apply $lambda} msg] $msg
} {1 foo}
# Tests for correct execution; as the implementation is the same as that for
# procs, the general functionality is mostly tested elsewhere
test apply-6.1 {info level} {
set lev [info level]
set lambda [list {} {info level}]
expr {[apply $lambda] - $lev}
} 1
test apply-6.2 {info level} tcl {
set lambda [list {} {info level 0}]
apply $lambda
} {apply {{} {info level 0}}}
test apply-6.3 {info level} tcl {
set lambda [list args {info level 0}]
apply $lambda x y
} {apply {args {info level 0}} x y}
# Tests for correct argument treatment
set applyBody {
set res {}
foreach v [info locals] {
if {$v eq "res"} continue
lappend res [list $v [set $v]]
}
set res
}
test apply-8.1 {args treatment} {
apply [list args $applyBody] 1 2 3
} {{args {1 2 3}}}
test apply-8.2 {args treatment} {
apply [list {x args} $applyBody] 1 2
} {{x 1} {args 2}}
test apply-8.3 {args treatment} {
apply [list {x args} $applyBody] 1 2 3
} {{x 1} {args {2 3}}}
test apply-8.4 {default values} {
apply [list {{x 1} {y 2}} $applyBody]
} {{x 1} {y 2}}
test apply-8.5 {default values} {
apply [list {{x 1} {y 2}} $applyBody] 3 4
} {{x 3} {y 4}}
test apply-8.6 {default values} {
apply [list {{x 1} {y 2}} $applyBody] 3
} {{x 3} {y 2}}
test apply-8.7 {default values} {
apply [list {x {y 2}} $applyBody] 1
} {{x 1} {y 2}}
test apply-8.8 {default values} {
apply [list {x {y 2}} $applyBody] 1 3
} {{x 1} {y 3}}
test apply-8.9 {default values} {
apply [list {x {y 2} args} $applyBody] 1
} {{x 1} {y 2} {args {}}}
test apply-8.10 {default values} {
apply [list {x {y 2} args} $applyBody] 1 3
} {{x 1} {y 3} {args {}}}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:

99
debuggers/openocd/jimtcl/tests/applyns.test Normal file
View File

@ -0,0 +1,99 @@
# Commands covered: apply
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2005-2006 Miguel Sofer
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
needs cmd apply
needs cmd namespace
# Tests for runtime errors in the lambda expression
# Note: Jim doesn't have the concept of non-existent namespaces
test apply-3.1 {non-existing namespace} -constraints tcl -body {
apply [list x {set x 1} ::NONEXIST::FOR::SURE] x
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
test apply-3.2 {non-existing namespace} -constraints tcl -body {
namespace eval ::NONEXIST::FOR::SURE {}
set lambda [list x {set x 1} ::NONEXIST::FOR::SURE]
apply $lambda x
namespace delete ::NONEXIST
apply $lambda x
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
test apply-3.3 {non-existing namespace} -constraints tcl -body {
apply [list x {set x 1} NONEXIST::FOR::SURE] x
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
test apply-3.4 {non-existing namespace} -constraints tcl -body {
namespace eval ::NONEXIST::FOR::SURE {}
set lambda [list x {set x 1} NONEXIST::FOR::SURE]
apply $lambda x
namespace delete ::NONEXIST
apply $lambda x
} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
# Tests for correct namespace scope
namespace eval ::testApply {
proc testApply args {return testApply}
}
test apply-7.1 {namespace access} {
set ::testApply::x 0
set body {set x 1; set x}
list [apply [list args $body ::testApply]] $::testApply::x
} {1 0}
test apply-7.2 {namespace access} {
set ::testApply::x 0
set body {variable x; set x}
list [apply [list args $body ::testApply]] $::testApply::x
} {0 0}
test apply-7.3 {namespace access} {
set ::testApply::x 0
set body {variable x; set x 1}
list [apply [list args $body ::testApply]] $::testApply::x
} {1 1}
test apply-7.4 {namespace access} {
set ::testApply::x 0
set body {testApply}
apply [list args $body ::testApply]
} testApply
test apply-7.5 {namespace access} {
set ::testApply::x 0
set body {set x 1; set x}
list [apply [list args $body testApply]] $::testApply::x
} {1 0}
test apply-7.6 {namespace access} {
set ::testApply::x 0
set body {variable x; set x}
list [apply [list args $body testApply]] $::testApply::x
} {0 0}
test apply-7.7 {namespace access} {
set ::testApply::x 0
set body {variable x; set x 1}
list [apply [list args $body testApply]] $::testApply::x
} {1 1}
test apply-7.8 {namespace access} {
set ::testApply::x 0
set body {testApply}
apply [list args $body testApply]
} testApply
namespace delete testApply
testreport
# Local Variables:
# mode: tcl
# fill-column: 78
# End:

88
debuggers/openocd/jimtcl/tests/array.test Normal file
View File

@ -0,0 +1,88 @@
source [file dirname [info script]]/testing.tcl
needs cmd array
unset -nocomplain a
array set a {
1 one
2 two
22 "twenty two"
3 three
}
test array-1.1 "array exists - true" {
array exists a
} {1}
test array-1.2 "array exists - false" {
array exists b
} {0}
test array-1.3 "array size" {
array size a
} {4}
test array-1.4 "array size - nonexistant" {
array size b
} {0}
test array-1.5 "array get" {
set result {}
foreach {name value} [array get a] {
lappend result $name $value
}
lsort $result
} {1 2 22 3 one three {twenty two} two}
test array-1.6 "array get - pattern" {
set result {}
foreach {name value} [array get a 2*] {
lappend result $name $value
}
lsort $result
} {2 22 {twenty two} two}
test array-1.7 "array names" {
lsort [array names a]
} {1 2 22 3}
test array-1.8 "array get - pattern" {
lsort [array names a 2*]
} {2 22}
#set b $a
array set b [array get a]
test array-1.9 "array set - replace" {
array set b {22 twenty-two}
set b(22)
} {twenty-two}
test array-1.10 "array unset - pattern" {
array unset b 2*
lsort [array names b]
} {1 3}
test array-1.11 "array unset - all" {
array unset b
list [array size b] [array exists b]
} {0 0}
test array-1.12 "array set to invalid variable" {
unset -nocomplain a b
set a 1
catch {array set a(1) {b c}}
} {1}
test array-1.13 "unset missing array element" {
unset -nocomplain a
set a(1) one
catch {unset a(2)}
} 1
test array-1.14 "access array via unset var" {
unset -nocomplain b
catch {expr {$a($b) + 4}}
} 1
testreport

660
debuggers/openocd/jimtcl/tests/binary-fmt.test Normal file
View File

@ -0,0 +1,660 @@
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: binary.test,v 1.38 2008/12/15 17:11:34 ferrieux Exp $
source [file dirname [info script]]/testing.tcl
needs cmd binary
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
# ----------------------------------------------------------------------
test binary-0.1 {DupByteArrayInternalRep} {
set hdr [binary format cc 0 0316]
set buf hellomatt
set data $hdr
append data $buf
string length $data
} 11
test binary-1.1 {Tcl_BinaryObjCmd: bad args} -body {
binary
} -returnCodes error -match glob -result {wrong # args: *}
test binary-1.2 {Tcl_BinaryObjCmd: bad args} -returnCodes error -body {
binary foo
} -match glob -result {*}
test binary-1.3 {Tcl_BinaryObjCmd: format error} -returnCodes error -body {
binary f
} -match glob -result {*}
test binary-1.4 {Tcl_BinaryObjCmd: format} -body {
binary format ""
} -result {}
test binary-2.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format a
} -result {not enough arguments for all format specifiers}
test binary-2.2 {Tcl_BinaryObjCmd: format} {
binary format a0 foo
} {}
test binary-2.3 {Tcl_BinaryObjCmd: format} {
binary format a f
} {f}
test binary-2.4 {Tcl_BinaryObjCmd: format} {
binary format a foo
} {f}
test binary-2.5 {Tcl_BinaryObjCmd: format} {
binary format a3 foo
} {foo}
test binary-2.6 {Tcl_BinaryObjCmd: format} {
binary format a5 foo
} foo\x00\x00
test binary-2.7 {Tcl_BinaryObjCmd: format} {
binary format a*a3 foobarbaz blat
} foobarbazbla
test binary-2.8 {Tcl_BinaryObjCmd: format} {
binary format a*X3a2 foobar x
} foox\x00r
test binary-3.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format A
} -result {not enough arguments for all format specifiers}
test binary-3.2 {Tcl_BinaryObjCmd: format} {
binary format A0 f
} {}
test binary-3.3 {Tcl_BinaryObjCmd: format} {
binary format A f
} {f}
test binary-3.4 {Tcl_BinaryObjCmd: format} {
binary format A foo
} {f}
test binary-3.5 {Tcl_BinaryObjCmd: format} {
binary format A3 foo
} {foo}
test binary-3.6 {Tcl_BinaryObjCmd: format} {
binary format A5 foo
} {foo }
test binary-3.7 {Tcl_BinaryObjCmd: format} {
binary format A*A3 foobarbaz blat
} foobarbazbla
test binary-3.8 {Tcl_BinaryObjCmd: format} {
binary format A*X3A2 foobar x
} {foox r}
test binary-4.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format B
} -result {not enough arguments for all format specifiers}
test binary-4.2 {Tcl_BinaryObjCmd: format} {
binary format B0 1
} {}
test binary-4.3 {Tcl_BinaryObjCmd: format} {
binary format B 1
} \x80
test binary-4.4 {Tcl_BinaryObjCmd: format} {
binary format B* 010011
} \x4c
test binary-4.5 {Tcl_BinaryObjCmd: format} {
binary format B8 01001101
} \x4d
test binary-4.6 {Tcl_BinaryObjCmd: format} {
binary format A2X2B9 oo 01001101
} \x4d\x00
test binary-4.7 {Tcl_BinaryObjCmd: format} {
binary format B9 010011011010
} \x4d\x80
test binary-4.8 {Tcl_BinaryObjCmd: format} {
binary format B2B3 10 010
} \x80\x40
test binary-4.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format B1B5 1 foo
} -match glob -result {expected *}
test binary-5.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format b
} -result {not enough arguments for all format specifiers}
test binary-5.2 {Tcl_BinaryObjCmd: format} {
binary format b0 1
} {}
test binary-5.3 {Tcl_BinaryObjCmd: format} {
binary format b 1
} \x01
test binary-5.4 {Tcl_BinaryObjCmd: format} {
binary format b* 010011
} 2
test binary-5.5 {Tcl_BinaryObjCmd: format} {
binary format b8 01001101
} \xb2
test binary-5.6 {Tcl_BinaryObjCmd: format} {
binary format A2X2b9 oo 01001101
} \xb2\x00
test binary-5.7 {Tcl_BinaryObjCmd: format} {
binary format b9 010011011010
} \xb2\x01
test binary-5.8 {Tcl_BinaryObjCmd: format} {
binary format b17 1
} \x01\00\00
test binary-5.9 {Tcl_BinaryObjCmd: format} {
binary format b2b3 10 010
} \x01\x02
test binary-5.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format b1b5 1 foo
} -match glob -result {expected *}
test binary-6.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format h
} -result {not enough arguments for all format specifiers}
test binary-6.2 {Tcl_BinaryObjCmd: format} {
binary format h0 1
} {}
test binary-6.3 {Tcl_BinaryObjCmd: format} {
binary format h 1
} \x01
test binary-6.4 {Tcl_BinaryObjCmd: format} {
binary format h c
} \x0c
test binary-6.5 {Tcl_BinaryObjCmd: format} {
binary format h* baadf00d
} \xab\xda\x0f\xd0
test binary-6.6 {Tcl_BinaryObjCmd: format} {
binary format h4 c410
} \x4c\x01
test binary-6.7 {Tcl_BinaryObjCmd: format} {
binary format h6 c4102
} \x4c\x01\x02
test binary-6.8 {Tcl_BinaryObjCmd: format} {
binary format h5 c41020304
} \x4c\x01\x02
test binary-6.9 {Tcl_BinaryObjCmd: format} {
binary format a3X3h5 foo 2
} \x02\x00\x00
test binary-6.10 {Tcl_BinaryObjCmd: format} {
binary format h2h3 23 456
} \x32\x54\x06
test binary-6.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format h2 foo
} -match glob -result {expected *}
test binary-7.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format H
} -result {not enough arguments for all format specifiers}
test binary-7.2 {Tcl_BinaryObjCmd: format} {
binary format H0 1
} {}
test binary-7.3 {Tcl_BinaryObjCmd: format} {
binary format H 1
} \x10
test binary-7.4 {Tcl_BinaryObjCmd: format} {
binary format H c
} \xc0
test binary-7.5 {Tcl_BinaryObjCmd: format} {
binary format H* baadf00d
} \xba\xad\xf0\x0d
test binary-7.6 {Tcl_BinaryObjCmd: format} {
binary format H4 c410
} \xc4\x10
test binary-7.7 {Tcl_BinaryObjCmd: format} {
binary format H6 c4102
} \xc4\x10\x20
test binary-7.8 {Tcl_BinaryObjCmd: format} {
binary format H5 c41023304
} \xc4\x10\x20
test binary-7.9 {Tcl_BinaryObjCmd: format} {
binary format a3X3H5 foo 2
} \x20\x00\x00
test binary-7.10 {Tcl_BinaryObjCmd: format} {
binary format H2H3 23 456
} \x23\x45\x60
test binary-7.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format H2 foo
} -match glob -result {expected *}
test binary-8.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format c
} -result {not enough arguments for all format specifiers}
test binary-8.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format c blat
} -match glob -result {expected *}
test binary-8.3 {Tcl_BinaryObjCmd: format} {
binary format c0 0x50
} {}
test binary-8.4 {Tcl_BinaryObjCmd: format} {
binary format c 0x50
} P
test binary-8.5 {Tcl_BinaryObjCmd: format} {
binary format c 0x5052
} R
test binary-8.6 {Tcl_BinaryObjCmd: format} {
binary format c2 {0x50 0x52}
} PR
test binary-8.7 {Tcl_BinaryObjCmd: format} {
binary format c2 {0x50 0x52 0x53}
} PR
test binary-8.8 {Tcl_BinaryObjCmd: format} {
binary format c* {0x50 0x52}
} PR
test binary-8.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format c2 {0x50}
} -result {number of elements in list does not match count}
test binary-8.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format c $a
} -result "expected integer but got \"0x50 0x51\""
test binary-8.11 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format c1 $a
} P
test binary-9.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format s
} -result {not enough arguments for all format specifiers}
test binary-9.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format s blat
} -result {expected integer but got "blat"}
test binary-9.3 {Tcl_BinaryObjCmd: format} {
binary format s0 0x50
} {}
test binary-9.4 {Tcl_BinaryObjCmd: format} {
binary format s 0x50
} P\x00
test binary-9.5 {Tcl_BinaryObjCmd: format} {
binary format s 0x5052
} RP
test binary-9.6 {Tcl_BinaryObjCmd: format} {
binary format s 0x505251 0x53
} QR
test binary-9.7 {Tcl_BinaryObjCmd: format} {
binary format s2 {0x50 0x52}
} P\x00R\x00
test binary-9.8 {Tcl_BinaryObjCmd: format} {
binary format s* {0x5051 0x52}
} QPR\x00
test binary-9.9 {Tcl_BinaryObjCmd: format} {
binary format s2 {0x50 0x52 0x53} 0x54
} P\x00R\x00
test binary-9.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format s2 {0x50}
} -result {number of elements in list does not match count}
test binary-9.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format s $a
} -result "expected integer but got \"0x50 0x51\""
test binary-9.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format s1 $a
} P\x00
test binary-10.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format S
} -result {not enough arguments for all format specifiers}
test binary-10.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format S blat
} -result {expected integer but got "blat"}
test binary-10.3 {Tcl_BinaryObjCmd: format} {
binary format S0 0x50
} {}
test binary-10.4 {Tcl_BinaryObjCmd: format} {
binary format S 0x50
} \x00P
test binary-10.5 {Tcl_BinaryObjCmd: format} {
binary format S 0x5052
} PR
test binary-10.6 {Tcl_BinaryObjCmd: format} {
binary format S 0x505251 0x53
} RQ
test binary-10.7 {Tcl_BinaryObjCmd: format} {
binary format S2 {0x50 0x52}
} \x00P\x00R
test binary-10.8 {Tcl_BinaryObjCmd: format} {
binary format S* {0x5051 0x52}
} PQ\x00R
test binary-10.9 {Tcl_BinaryObjCmd: format} {
binary format S2 {0x50 0x52 0x53} 0x54
} \x00P\x00R
test binary-10.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format S2 {0x50}
} -result {number of elements in list does not match count}
test binary-10.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format S $a
} -result "expected integer but got \"0x50 0x51\""
test binary-10.12 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format S1 $a
} \x00P
test binary-11.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i
} -result {not enough arguments for all format specifiers}
test binary-11.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i blat
} -result {expected integer but got "blat"}
test binary-11.3 {Tcl_BinaryObjCmd: format} {
binary format i0 0x50
} {}
test binary-11.4 {Tcl_BinaryObjCmd: format} {
binary format i 0x50
} P\x00\x00\x00
test binary-11.5 {Tcl_BinaryObjCmd: format} {
binary format i 0x5052
} RP\x00\x00
test binary-11.6 {Tcl_BinaryObjCmd: format} {
binary format i 0x505251 0x53
} QRP\x00
test binary-11.7 {Tcl_BinaryObjCmd: format} {
binary format i1 {0x505251 0x53}
} QRP\x00
test binary-11.8 {Tcl_BinaryObjCmd: format} {
binary format i 0x53525150
} PQRS
test binary-11.9 {Tcl_BinaryObjCmd: format} {
binary format i2 {0x50 0x52}
} P\x00\x00\x00R\x00\x00\x00
test binary-11.10 {Tcl_BinaryObjCmd: format} {
binary format i* {0x50515253 0x52}
} SRQPR\x00\x00\x00
test binary-11.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i2 {0x50}
} -result {number of elements in list does not match count}
test binary-11.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format i $a
} -result "expected integer but got \"0x50 0x51\""
test binary-11.13 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format i1 $a
} P\x00\x00\x00
test binary-12.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format I
} -result {not enough arguments for all format specifiers}
test binary-12.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format I blat
} -result {expected integer but got "blat"}
test binary-12.3 {Tcl_BinaryObjCmd: format} {
binary format I0 0x50
} {}
test binary-12.4 {Tcl_BinaryObjCmd: format} {
binary format I 0x50
} \x00\x00\x00P
test binary-12.5 {Tcl_BinaryObjCmd: format} {
binary format I 0x5052
} \x00\x00PR
test binary-12.6 {Tcl_BinaryObjCmd: format} {
binary format I 0x505251 0x53
} \x00PRQ
test binary-12.7 {Tcl_BinaryObjCmd: format} {
binary format I1 {0x505251 0x53}
} \x00PRQ
test binary-12.8 {Tcl_BinaryObjCmd: format} {
binary format I 0x53525150
} SRQP
test binary-12.9 {Tcl_BinaryObjCmd: format} {
binary format I2 {0x50 0x52}
} \x00\x00\x00P\x00\x00\x00R
test binary-12.10 {Tcl_BinaryObjCmd: format} {
binary format I* {0x50515253 0x52}
} PQRS\x00\x00\x00R
test binary-12.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format i2 {0x50}
} -result {number of elements in list does not match count}
test binary-12.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format I $a
} -result "expected integer but got \"0x50 0x51\""
test binary-12.13 {Tcl_BinaryObjCmd: format} {
set a {0x50 0x51}
binary format I1 $a
} \x00\x00\x00P
test binary-15.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format ax*a "y" "z"
} -result {cannot use "*" in format string with "x"}
test binary-15.2 {Tcl_BinaryObjCmd: format} {
binary format axa "y" "z"
} y\x00z
test binary-15.3 {Tcl_BinaryObjCmd: format} {
binary format ax3a "y" "z"
} y\x00\x00\x00z
test binary-15.4 {Tcl_BinaryObjCmd: format} {
binary format a*X3x3a* "foo" "z"
} \x00\x00\x00z
test binary-15.5 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x0s 1
} \x01\x00
test binary-15.6 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x0ss 1 1
} \x01\x00\x01\x00
test binary-15.7 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x1s 1
} \x00\x01\x00
test binary-15.8 {Tcl_BinaryObjCmd: format - bug #1923966} {
binary format x1ss 1 1
} \x00\x01\x00\x01\x00
test binary-16.1 {Tcl_BinaryObjCmd: format} {
binary format a*X*a "foo" "z"
} zoo
test binary-16.2 {Tcl_BinaryObjCmd: format} {
binary format aX3a "y" "z"
} z
test binary-16.3 {Tcl_BinaryObjCmd: format} {
binary format a*Xa* "foo" "zy"
} fozy
test binary-16.4 {Tcl_BinaryObjCmd: format} {
binary format a*X3a "foobar" "z"
} foozar
test binary-16.5 {Tcl_BinaryObjCmd: format} {
binary format a*X3aX2a "foobar" "z" "b"
} fobzar
test binary-17.1 {Tcl_BinaryObjCmd: format} {
binary format @1
} \x00
test binary-17.2 {Tcl_BinaryObjCmd: format} {
binary format @5a2 "ab"
} \x00\x00\x00\x00\x00\x61\x62
test binary-17.3 {Tcl_BinaryObjCmd: format} {
binary format {a* @0 a2 @* a*} "foobar" "ab" "blat"
} abobarblat
test binary-18.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format u0a3 abc abd
} -result {bad field specifier "u"}
# GetFormatSpec is pretty thoroughly tested above, but there are a few cases
# we should text explicitly
test binary-37.1 {GetFormatSpec: whitespace} {
binary format "a3 a5 a3" foo barblat baz
} foobarblbaz
test binary-37.2 {GetFormatSpec: whitespace} {
binary format " " foo
} {}
test binary-37.3 {GetFormatSpec: whitespace} {
binary format " a3" foo
} foo
test binary-37.4 {GetFormatSpec: whitespace} {
binary format "" foo
} {}
test binary-37.5 {GetFormatSpec: whitespace} {
binary format "" foo
} {}
test binary-37.6 {GetFormatSpec: whitespace} {
binary format " a3 " foo
} foo
test binary-38.1 {FormatNumber: word alignment} {
set x [binary format c1s1 1 1]
} \x01\x01\x00
test binary-38.2 {FormatNumber: word alignment} {
set x [binary format c1S1 1 1]
} \x01\x00\x01
test binary-38.3 {FormatNumber: word alignment} {
set x [binary format c1i1 1 1]
} \x01\x01\x00\x00\x00
test binary-38.4 {FormatNumber: word alignment} {
set x [binary format c1I1 1 1]
} \x01\x00\x00\x00\x01
# Wide int (guaranteed at least 64-bit) handling
test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} {
binary format w 7810179016327718216
} HelloTcl
test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
} lcTolleH
### TIP#129: endian specifiers ----
# format t
test binary-48.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format t
} -result {not enough arguments for all format specifiers}
test binary-48.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format t blat
} -result {expected integer but got "blat"}
test binary-48.3 {Tcl_BinaryObjCmd: format} {
binary format S0 0x50
} {}
test binary-48.4 {Tcl_BinaryObjCmd: format} bigEndian {
binary format t 0x50
} \x00P
test binary-48.5 {Tcl_BinaryObjCmd: format} littleEndian {
binary format t 0x50
} P\x00
test binary-48.6 {Tcl_BinaryObjCmd: format} bigEndian {
binary format t 0x5052
} PR
test binary-48.7 {Tcl_BinaryObjCmd: format} littleEndian {
binary format t 0x5052
} RP
test binary-48.8 {Tcl_BinaryObjCmd: format} bigEndian {
binary format t 0x505251 0x53
} RQ
test binary-48.9 {Tcl_BinaryObjCmd: format} littleEndian {
binary format t 0x505251 0x53
} QR
test binary-48.10 {Tcl_BinaryObjCmd: format} bigEndian {
binary format t2 {0x50 0x52}
} \x00P\x00R
test binary-48.11 {Tcl_BinaryObjCmd: format} littleEndian {
binary format t2 {0x50 0x52}
} P\x00R\x00
test binary-48.12 {Tcl_BinaryObjCmd: format} bigEndian {
binary format t* {0x5051 0x52}
} PQ\x00R
test binary-48.13 {Tcl_BinaryObjCmd: format} littleEndian {
binary format t* {0x5051 0x52}
} QPR\x00
test binary-48.14 {Tcl_BinaryObjCmd: format} bigEndian {
binary format t2 {0x50 0x52 0x53} 0x54
} \x00P\x00R
test binary-48.15 {Tcl_BinaryObjCmd: format} littleEndian {
binary format t2 {0x50 0x52 0x53} 0x54
} P\x00R\x00
test binary-48.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format t2 {0x50}
} -result {number of elements in list does not match count}
test binary-48.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format t $a
} -result "expected integer but got \"0x50 0x51\""
test binary-48.18 {Tcl_BinaryObjCmd: format} bigEndian {
set a {0x50 0x51}
binary format t1 $a
} \x00P
test binary-48.19 {Tcl_BinaryObjCmd: format} littleEndian {
set a {0x50 0x51}
binary format t1 $a
} P\x00
# format n
test binary-49.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format n
} -result {not enough arguments for all format specifiers}
test binary-49.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format n blat
} -result {expected integer but got "blat"}
test binary-49.3 {Tcl_BinaryObjCmd: format} {
binary format n0 0x50
} {}
test binary-49.4 {Tcl_BinaryObjCmd: format} littleEndian {
binary format n 0x50
} P\x00\x00\x00
test binary-49.5 {Tcl_BinaryObjCmd: format} littleEndian {
binary format n 0x5052
} RP\x00\x00
test binary-49.6 {Tcl_BinaryObjCmd: format} littleEndian {
binary format n 0x505251 0x53
} QRP\x00
test binary-49.7 {Tcl_BinaryObjCmd: format} littleEndian {
binary format i1 {0x505251 0x53}
} QRP\x00
test binary-49.8 {Tcl_BinaryObjCmd: format} littleEndian {
binary format n 0x53525150
} PQRS
test binary-49.9 {Tcl_BinaryObjCmd: format} littleEndian {
binary format n2 {0x50 0x52}
} P\x00\x00\x00R\x00\x00\x00
test binary-49.10 {Tcl_BinaryObjCmd: format} littleEndian {
binary format n* {0x50515253 0x52}
} SRQPR\x00\x00\x00
test binary-49.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
binary format n2 {0x50}
} -result {number of elements in list does not match count}
test binary-49.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
set a {0x50 0x51}
binary format n $a
} -result "expected integer but got \"0x50 0x51\""
test binary-49.13 {Tcl_BinaryObjCmd: format} littleEndian {
set a {0x50 0x51}
binary format n1 $a
} P\x00\x00\x00
test binary-49.14 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n 0x50
} \x00\x00\x00P
test binary-49.15 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n 0x5052
} \x00\x00PR
test binary-49.16 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n 0x505251 0x53
} \x00PRQ
test binary-49.17 {Tcl_BinaryObjCmd: format} bigEndian {
binary format i1 {0x505251 0x53}
} QRP\x00
test binary-49.18 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n 0x53525150
} SRQP
test binary-49.19 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n2 {0x50 0x52}
} \x00\x00\x00P\x00\x00\x00R
test binary-49.20 {Tcl_BinaryObjCmd: format} bigEndian {
binary format n* {0x50515253 0x52}
} PQRS\x00\x00\x00R
# format m
test binary-50.1 {Tcl_BinaryObjCmd: format wide int} littleEndian {
binary format m 7810179016327718216
} HelloTcl
test binary-50.2 {Tcl_BinaryObjCmd: format wide int} bigEndian {
binary format m 7810179016327718216
} lcTolleH
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:

1099
debuggers/openocd/jimtcl/tests/binary-scan.test Normal file
View File

File diff suppressed because it is too large Load Diff

1
debuggers/openocd/jimtcl/tests/break.tcl Normal file
View File

@ -0,0 +1 @@
break

86
debuggers/openocd/jimtcl/tests/case.test Normal file
View File

@ -0,0 +1,86 @@
source [file dirname [info script]]/testing.tcl
needs cmd case {tclcompat}
catch {unset result}
test case-1.1 "Simple case" {
foreach c {abc xyz def sdfbc basdf a aba} {
case $c in {
b* {
lappend result 1
}
{ab a} {
lappend result 2
}
{def *bc} {
lappend result 3
}
default {
lappend result 4
}
}
}
set result
} {3 4 3 3 1 2 4}
# case is a proc, but it should be able
# to cause a return in do_case
proc do_case {var} {
case $var in {
0 {
return
}
1 {
return one
}
2 {
return -code ok two
}
3 {
return -code continue three
}
4 {
return -code break four
}
5 {
continue
}
6 {
break
}
}
return zero
}
test case-2.0 "Plain from case" {
do_case 0
} {}
test case-2.1 "Return from case with value" {
do_case 1
} {one}
test case-2.2 "Return -code ok from case" {
do_case 2
list [catch {do_case 2} msg] $msg
} {0 two}
test case-2.3 "Return -code continue from case" {
list [catch {do_case 3} msg] $msg
} {4 three}
test case-2.4 "Return -code break from case" {
list [catch {do_case 4} msg] $msg
} {3 four}
if {0} {
test case-2.5 "continue from case" {
list [catch {do_case 5} msg] $msg
} {1 {invoked "continue" outside of a loop}}
test case-2.6 "break from case" {
list [catch {do_case 6} msg] $msg
} {1 {invoked "break" outside of a loop}}
}
testreport

66
debuggers/openocd/jimtcl/tests/concat.test Normal file
View File

@ -0,0 +1,66 @@
source [file dirname [info script]]/testing.tcl
test concat-1.1 {simple concatenation} {
concat a b c d e f g
} {a b c d e f g}
test concat-1.2 {merging lists together} {
concat a {b c d} {e f g h}
} {a b c d e f g h}
test concat-1.3 {merge lists, retain sub-lists} {
concat a {b {c d}} {{e f}} g h
} {a b {c d} {e f} g h}
test concat-1.4 {special characters} {
concat a\{ {b \{c d} \{d
} "a{ b \\{c d {d"
test concat-2.1 {error check: one empty argument} {
concat {}
} {}
test concat-3.1 {error check: no arguments} {
list [catch concat msg] $msg
} {0 {}}
test concat-4.1 {pruning off extra white space} {
concat {} {a b c}
} {a b c}
test concat-4.2 {pruning off extra white space} {
concat x y " a b c \n\t " " " " def "
} {x y a b c def}
test concat-4.3 {pruning off extra white space sets length correctly} {
llength [concat { {{a}} }]
} 1
test concat-5.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces} {
# This test checks for a very tricky feature. Any list element
# generated with Tcl_ScanCountedElement and Tcl_ConvertElement must
# have the property that it can be enclosing in curly braces to make
# an embedded sub-list. If this property doesn't hold, then
# Tcl_DStringStartSublist doesn't work.
set x {}
lappend x " \\\{ \\"
concat $x [llength "{$x}"]
} {\ \\\{\ \\ 1}
test concat-6.1 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b\ } c
} {a b\ c}
test concat-6.2 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b\ } c
} {a b\ c}
test concat-6.3 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b\\ } c
} {a b\\ c}
test concat-6.4 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b } c
} {a b c}
test concat-6.5 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a { } c
} {a c}
test concat-6.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} {
# Check for Bug #227512. If this violates C isspace, then it returns \xc3.
concat \xe0
} \xe0
testreport

233
debuggers/openocd/jimtcl/tests/dict.test Normal file
View File

@ -0,0 +1,233 @@
source [file dirname [info script]]/testing.tcl
test dict-1.1 "Basic dict" {
set d [dict create]
dict set d fruit apple
dict set d car holden
#puts "d=$d"
#puts "d(fruit)=$d(fruit)"
dict get $d car
} {holden}
catch {unset d}
test dict-2.1 "Dict via reference" references {
set d [dict create]
dict set d fruit apple
dict set d car holden
# now create a dictionary reference
set dref [ref $d dict]
dict get [getref $dref] car
} {holden}
test dict-2.2 "Modify dict via reference" references {
# Get the value out of the refernence
set d [getref $dref]
# Modify it
dict set d car toyota
# And put the new value back
setref $dref $d
# Finally check it
dict get [getref $dref] car
} {toyota}
test dict-2.3 "Modify dict via reference - one line" references {
# Get the value out of the refernence
set d [getref $dref]
setref $dref [dict set d car toyota]
# Finally check it
dict get [getref $dref] car
} {toyota}
# Sort a dictionary in key order - return a list
proc dictsort {dict} {
set result {}
foreach k [lsort [dict keys $dict]] {
lappend result $k [dict get $dict $k]
}
return $result
}
set a [dict create a 1 b 2]
set b [dict create b 3 c 4]
test dict-3.1 {Merge} {
dict merge
} {}
test dict-3.2 {Merge} {
dictsort [dict merge $a]
} {a 1 b 2}
test dict-3.3 {Merge} {
dictsort [dict merge $b]
} {b 3 c 4}
test dict-3.4 {Merge} {
dictsort [dict merge $a $b]
} {a 1 b 3 c 4}
test dict-3.5 {Merge} {
dictsort [dict merge $b $a]
} {a 1 b 2 c 4}
test dict-3.6 {Merge} {
dictsort [dict merge $b $a {a 5}]
} {a 5 b 2 c 4}
test dict-3.7 {Merge} {
dictsort [dict merge {a 5} $b $a]
} {a 1 b 2 c 4}
test dict-3.8 {Merge} {
catch {dict merge 1 $b $a}
} 1
test dict-3.9 {Merge} {
catch {dict merge $b 1 $a}
} 1
test dict-3.10 {Merge} {
catch {dict merge $b $a 1}
} 1
test dict-3.11 {Merge} {
catch {dict merge 1}
} 1
test dict-4.1 {Dict size} {
dict size {a b}
} 1
test dict-4.2 {Dict size} {
dict size {a b c d}
} 2
test dict-5.1 {Dict with} {
proc a {} {
set x [dict create a b c d]
dict with x {
set a B
unset c
}
set x
}
dictsort [a]
} {a B}
test dict-5.2 {Dict with} {
proc a {} {
set x [dict create a b c d]
dict with x {
set a B
unset c
}
set x
}
dictsort [a]
} {a B}
test dict-22.1 {dict with command} {
list [catch {dict with} msg] $msg
} {1 {wrong # args: should be "dict with dictVar ?key ...? script"}}
test dict-22.2 {dict with command} {
list [catch {dict with v} msg] $msg
} {1 {wrong # args: should be "dict with dictVar ?key ...? script"}}
test dict-22.3 {dict with command} {
unset -nocomplain v
list [catch {dict with v {error "in body"}} msg] $msg
} {1 {can't read "v": no such variable}}
test dict-22.4 {dict with command} {
set a {b c d e}
unset -nocomplain b d
set result [list [info exist b] [info exist d]]
dict with a {
lappend result [info exist b] [info exist d] $b $d
}
set result
} {0 0 1 1 c e}
test dict-22.5 {dict with command} {
set a {b c d e}
dict with a {
lassign "$b $d" d b
}
dictsort $a
} {b e d c}
test dict-22.6 {dict with command} {
set a {b c d e}
dict with a {
unset b
# This *won't* go into the dict...
set f g
}
set a
} {d e}
test dict-22.7 {dict with command} {
set a {b c d e}
dict with a {
dict unset a b
}
dictsort $a
} {b c d e}
test dict-22.8 {dict with command} {
set a [dict create b c]
dict with a {
set b $a
}
set a
} {b {b c}}
test dict-22.9 {dict with command} {
set a {b {c d}}
dict with a b {
set c $c$c
}
set a
} {b {c dd}}
test dict-22.10 {dict with command: result handling tricky case} {
set a {b {c d}}
foreach i {0 1} {
if {$i} break
dict with a b {
set a {}
# We're checking to see if we lose this break
break
}
}
list $i $a
} {0 {}}
test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} {
set foo {t {t {t {inner 1}}}}
dict with foo {
dict with t {
dict with t {
dict with t {
incr inner
}
}
}
}
string range [append foo OK] end-1 end
} OK
test dict-23.1 {dict unset missing last level} {
set a {b c d e}
dict unset a xyz
dict size $a
} 2
test dict-23.2 {dict unset command} -returnCodes error -body {
set dictVar a
dict unset dictVar a
} -cleanup {
unset dictVar
} -result {missing value to go with key}
test dict-23.3 {dict unset command} -setup {
unset -nocomplain dictVar
} -body {
list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]
} -cleanup {
unset dictVar
} -result {0 {} 1}
test dict-23.4 {dict unset command: write failure} -setup {
unset -nocomplain dictVar
} -body {
set dictVar 1
dict unset dictVar a
} -returnCodes error -cleanup {
unset dictVar
} -result {missing value to go with key}
test dict-24.1 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;set l} {p 1 p 2 q 3}
test dict-24.2 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;llength $l} 6
testreport

6
debuggers/openocd/jimtcl/tests/dummy.tcl Normal file
View File

@ -0,0 +1,6 @@
# generates an error
proc dummyproc {} {
error "from dummyproc"
}
dummyproc

55
debuggers/openocd/jimtcl/tests/error.test Normal file
View File

@ -0,0 +1,55 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim; needs cmd package
proc a {} {
error "error thrown from a"
}
proc b {} {
set rc [catch {a} msg]
if {$rc} {
error $msg [info stacktrace]
}
}
test error-1.1 "Rethrow caught error" {
set rc [catch {b} msg]
#puts stderr "error-1.1\n[errorInfo $msg]\n"
list $rc $msg [info stacktrace]
} {1 {error thrown from a} {{} error.test 4 a error.test 8 b error.test 15}}
proc c {} {
a
}
proc d {} {
c
}
proc e {} {
d
}
test error-1.2 "Modify stacktrace" {
set rc [catch {e} msg]
set st [info stacktrace]
# Now elide one entry from the stacktrace
#puts [errorInfo $msg]
set newst {}
foreach {p f l} $st {
if {$p ne "d"} {
lappend newst $p $f $l
}
}
# Now rethrow with the new stack
set rc [catch {error $msg $newst} msg]
#puts [errorInfo $msg]
info stacktrace
} {{} error.test 4 a error.test 22 c error.test 26 e error.test 34}
# Package should be able to invoke exit, which should exit if not caught
test error-2.1 "Exit from package" {
list [catch -exit {package require exitpackage} msg] $msg
} {6 {Can't load package exitpackage}}
testreport

59
debuggers/openocd/jimtcl/tests/errors.tcl Normal file
View File

@ -0,0 +1,59 @@
# Package which can generate a variety of errors at known locations
proc error_generator {type} {
switch $type {
badcmd {
bogus command called
}
badvar {
set bogus
}
error {
error bogus
}
interpbadvar {
set x "some $bogus text"
}
interpbadcmd {
set x "some $bogus text"
}
package {
package require dummy
}
source {
source dummy.tcl
}
badpackage {
package require bogus
}
returncode {
return -code error failure
}
default {
puts "Unknown type=$type"
}
}
}
# line 40: Some empty lines above so that line numbers don't change
proc error_caller {type {method call}} {
switch $method {
call {
error_generator $type
}
uplevel {
uplevel 1 [list error_generator $type]
}
eval {
eval [list error_generator $type]
}
evalstr {
eval error_generator $type
}
default {
puts "Unknown method=$method"
}
}
}

192
debuggers/openocd/jimtcl/tests/event.test Normal file
View File

@ -0,0 +1,192 @@
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl
# commands. Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
needs cmd after eventloop
testConstraint socket [expr {[info commands socket] ne ""}]
testConstraint exec [expr {[info commands exec] ne ""}]
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} jim {
catch {rename bgerror {}}
proc bgerror msg {
lappend ::x $msg
}
after idle {error "a simple error"}
after idle {open non_existent}
after idle {set errorInfo foobar; set errorCode xyzzy}
set x {}
update idletasks
rename bgerror {}
set x
} {{a simple error} {non_existent: No such file or directory}}
test event-7.1 {bgerror / regular} {
set errRes {}
proc bgerror {err} {
global errRes;
set errRes $err;
}
after 0 {error err1}
vwait errRes;
set errRes;
} err1
test event-7.2 {bgerror / accumulation} {
set errRes {}
proc bgerror {err} {
global errRes;
lappend errRes $err;
}
after 0 {error err1}
after 0 {error err2}
after 0 {error err3}
update
set errRes;
} {err1 err2 err3}
test event-7.3 {bgerror / accumulation / break} {
set errRes {}
proc bgerror {err} {
global errRes;
lappend errRes $err;
return -code break "skip!";
}
after 0 {error err1}
after 0 {error err2}
after 0 {error err3}
update
set errRes;
} err1
# end of bgerror tests
catch {rename bgerror {}}
test event-10.1 {Tcl_Exit procedure} exec {
set cmd [list exec [info nameofexecutable] "<<exit 3"]
list [catch $cmd msg] [lindex $errorCode 0] \
[lindex $errorCode 2]
} {1 CHILDSTATUS 3}
test event-11.1 {Tcl_VwaitCmd procedure} {
list [catch {vwait} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
test event-11.2 {Tcl_VwaitCmd procedure} {
list [catch {vwait a b} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
test event-11.3 {Tcl_VwaitCmd procedure} jim {
catch {unset x}
set x 1
list [catch {vwait x(1)} msg] $msg
} {1 {can't read "x(1)": variable isn't array}}
test event-11.4 {Tcl_VwaitCmd procedure} {
foreach i [after info] {
after cancel $i
}
after 10; update; # On Mac make sure update won't take long
after 100 {set x x-done}
after 200 {set y y-done}
after 300 {set z z-done}
after idle {set q q-done}
set x before
set y before
set z before
set q before
list [vwait y] $x $y $z $q
} {{} x-done y-done before q-done}
foreach i [after info] {
after cancel $i
}
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {jim socket} {
set f1 [open test1 w]
proc accept {s args} {
puts $s foobar
close $s
}
set s1 [socket stream.server 5001]
after 200
set s2 [socket stream 127.0.0.1:5001]
close $s1
set x 0
set y 0
set z 0
fileevent $s2 readable { incr z }
vwait z
fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
fileevent $s2 readable { incr y; if { $x == 3 } { set z done } }
vwait z
close $f1
close $s2
file delete test1 test2
list $x $y $z
} {3 3 done}
# Note: This one doesn't really require socket, but mingw32 doesn't have socket and
# also doesn't allow file events (select) on non-sockets
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {socket} {
file delete test1 test2
set f1 [open test1 w]
set f2 [open test2 w]
set x 0
set y 0
set z 0
update
fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
vwait z
close $f1
close $f2
file delete test1 test2
list $x $y $z
} {3 3 done}
test event-12.1 {Tcl_UpdateCmd procedure} {
list [catch {update a b} msg] $msg
} {1 {wrong # args: should be "update ?idletasks?"}}
test event-12.3 {Tcl_UpdateCmd procedure} {
foreach i [after info] {
after cancel $i
}
after 500 {set x after}
after idle {set y after}
after idle {set z "after, y = $y"}
set x before
set y before
set z before
update idletasks
list $x $y $z
} {before after {after, y = after}}
test event-12.4 {Tcl_UpdateCmd procedure} {
foreach i [after info] {
after cancel $i
}
after 10; update; # On Mac make sure update won't take long
after 200 {set x x-done}
after 400 {set y y-done}
after idle {set z z-done}
set x before
set y before
set z before
after 300
update
list $x $y $z
} {x-done before z-done}
# cleanup
foreach i [after info] {
after cancel $i
}
testreport

418
debuggers/openocd/jimtcl/tests/exec.test Normal file
View File

@ -0,0 +1,418 @@
# Commands covered: exec
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: exec.test,v 1.8.2.1 2001/10/17 19:29:25 das Exp $
source [file dirname [info script]]/testing.tcl
needs cmd exec
# Sleep which supports fractions of a second
if {[info commands sleep] eq {}} {
proc sleep {n} {
after [expr {int($n * 1000)}]
}
}
set f [open sleepx w]
puts $f "#![info nameofexecutable]"
puts $f {
set seconds [lindex $argv 0]
after [expr {int($seconds * 1000)}]
}
close $f
#catch {exec chmod +x sleepx}
set sleepx [list [info nameofexecutable] sleepx]
# Basic operations.
test exec-1.1 {basic exec operation} {
exec echo a b c
} "a b c"
test exec-1.2 {pipelining} {
exec echo a b c d | cat | cat
} "a b c d"
test exec-1.3 {pipelining} {
set a [exec echo a b c d | cat | wc]
list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {
exec echo $arg
} $arg
set arg {}
# I/O redirection: input from Tcl command.
test exec-2.1 {redirecting input from immediate source} {
exec cat << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {
exec << "Sample text" cat | cat
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {
exec cat << "Sample text" | cat
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {
exec cat | cat << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {
exec cat "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} {
# If this fails, it may give back:
# "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
# If it does, this means that the UTF -> external conversion did not
# occur before writing out the temp file.
exec cat << "\uE9\uE0\uFC\uF1"
} "\uE9\uE0\uFC\uF1"
# I/O redirection: output to file.
file delete gorp.file
test exec-3.1 {redirecting output to file} {
exec echo "Some simple words" > gorp.file
exec cat gorp.file
} "Some simple words"
test exec-3.2 {redirecting output to file} {
exec echo "More simple words" | >gorp.file cat | cat
exec cat gorp.file
} "More simple words"
test exec-3.3 {redirecting output to file} {
exec > gorp.file echo "Different simple words" | cat | cat
exec cat gorp.file
} "Different simple words"
test exec-3.4 {redirecting output to file} {
exec echo "Some simple words" >gorp.file
exec cat gorp.file
} "Some simple words"
test exec-3.5 {redirecting output to file} {
exec echo "First line" >gorp.file
exec echo "Second line" >> gorp.file
exec cat gorp.file
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {
exec echo "First line" >gorp.file
exec echo "Second line" >>gorp.file
exec cat gorp.file
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
exec echo "More text" >@ $f
exec echo >@$f "Even more"
puts $f "Line 3"
close $f
exec cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
# I/O redirection: output and stderr to file.
file delete gorp.file
test exec-4.1 {redirecting output and stderr to file} {
exec echo "test output" >& gorp.file
exec cat gorp.file
} "test output"
test exec-4.2 {redirecting output and stderr to file} {
list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \
[exec cat gorp.file]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {
exec echo "first line" > gorp.file
list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \
[exec cat gorp.file]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
exec echo "More text" >&@ $f
exec echo >&@$f "Even more"
puts $f "Line 3"
close $f
exec cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
exec >&@ $f sh -c "echo foo bar 1>&2"
exec >&@$f sh -c "echo xyzzy 1>&2"
puts $f "Line 3"
close $f
exec cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"
# I/O redirection: input from file.
exec echo "Just a few thoughts" > gorp.file
test exec-5.1 {redirecting input from file} {
exec cat < gorp.file
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {
exec cat | cat < gorp.file
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {
exec cat < gorp.file | cat
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {
exec < gorp.file cat | cat
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {
exec cat <gorp.file
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {
set f [open gorp.file r]
set result [exec cat <@ $f]
close $f
set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {
set f [open gorp.file r]
set result [exec <@$f cat]
close $f
set result
} {Just a few thoughts}
# I/O redirection: standard error through a pipeline.
test exec-6.1 {redirecting stderr through a pipeline} {
exec sh -c "echo foo bar" |& cat
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {
exec sh -c "echo foo bar 1>&2" |& cat
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {
exec sh -c "echo foo bar 1>&2" \
|& cat |& cat
} "foo bar"
# I/O redirection: combinations.
file delete gorp.file2
test exec-7.1 {multiple I/O redirections} {
exec << "command input" > gorp.file2 cat < gorp.file
exec cat gorp.file2
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {
exec < gorp.file << "command input" cat
} {command input}
# Long input to command and output from command.
set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {
exec cat << $a
} $a
# More than 20 arguments to exec.
test exec-8.1 {long input and output} {
exec echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
# Commands that return errors.
test exec-9.1 {commands returning errors} {
catch {exec gorp456}
} {1}
test exec-9.2 {commands returning errors} {
catch {exec echo foo | foo123} msg
} {1}
test exec-9.3 {commands returning errors} {
list [catch {exec {*}$sleepx 0.1 | false | {*}$sleepx 0.1} msg]
} {1}
test exec-9.4 {commands returning errors} jim {
list [catch {exec false | echo "foo bar"} msg] $msg
} {1 {foo bar}}
test exec-9.5 {commands returning errors} {
list [catch {exec gorp456 | echo a b c} msg]
} {1}
test exec-9.6 {commands returning errors} jim {
list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg
} {0 {error msg}}
test exec-9.7 {commands returning errors} jim {
# Note: Use sleep here to ensure the order
list [catch {exec sh -c "echo error msg 1 1>&2" \
| sh -c "sleep 0.1; echo error msg 2 1>&2"} msg] $msg
} {0 {error msg 1
error msg 2}}
# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.
test exec-10.1 {errors in exec invocation} {
list [catch {exec} msg]
} {1}
test exec-10.2 {errors in exec invocation} {
list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {
list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {
list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {
list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {
list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {
list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {
list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {
list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {
list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {
list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {
list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {
list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {
list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {
list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
test exec-10.18 {errors in exec invocation} {
list [catch {exec cat <<test <@ $f} msg]
} 1
close $f
set f [open gorp.file r]
test exec-10.19 {errors in exec invocation} {
list [catch {exec cat <<test >@ $f} msg]
} 1
close $f
# Commands in background.
test exec-11.1 {commands in background} {
set x [lindex [time {exec {*}$sleepx 0.2 &}] 0]
expr $x<1000000
} 1
test exec-11.2 {commands in background} {
list [catch {exec echo a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {
llength [exec {*}$sleepx 0.1 &]
} 1
test exec-11.4 {commands in background} {
llength [exec {*}$sleepx 0.1 | {*}$sleepx 0.1 | {*}$sleepx 0.1 &]
} 3
# Make sure that background commands are properly reaped when
# they eventually die.
exec {*}$sleepx 0.3
test exec-12.1 {reaping background processes} -body {
for {set i 0} {$i < 20} {incr i} {
exec echo foo > exec.tmp1 &
}
exec {*}$sleepx 0.1
catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
lindex $msg 0
} -cleanup {
file delete exec.tmp1
} -result 0
# Redirecting standard error separately from standard output
test exec-15.1 {standard error redirection} {
exec echo "First line" > gorp.file
list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \
[exec cat gorp.file]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {
list [exec sh -c "echo foo bar 1>&2" \
| echo biz baz >gorp.file 2> gorp.file2] \
[exec cat gorp.file] \
[exec cat gorp.file2]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {
list [exec sh -c "echo foo bar 1>&2" \
| echo biz baz 2>gorp.file > gorp.file2] \
[exec cat gorp.file] \
[exec cat gorp.file2]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {
set f [open gorp.file w]
puts $f "Line 1"
flush $f
exec sh -c "echo foo bar 1>&2" 2>@ $f
puts $f "Line 3"
close $f
exec cat gorp.file
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {
exec echo "First line" > gorp.file
exec sh -c "echo foo bar 1>&2" 2>> gorp.file
exec cat gorp.file
} {First line
foo bar}
test exec-15.6 {standard error redirection} {
exec sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
>& gorp.file 2> gorp.file2 | echo biz baz
list [exec cat gorp.file] [exec cat gorp.file2]
} {{biz baz} {foo bar}}
test exec-15.7 {combine standard output/standard error} -body {
exec sh -c "echo foo bar 1>&2" > gorp.file 2>@1
exec cat gorp.file
} -cleanup {
file delete gorp.file gorp.file2
} -result {foo bar}
test exec-16.1 {flush output before exec} -body {
set f [open gorp.file w]
puts $f "First line"
exec echo "Second line" >@ $f
puts $f "Third line"
close $f
exec cat gorp.file
} -cleanup {
file delete gorp.file
} -result {First line
Second line
Third line}
file delete sleepx
testreport

47
debuggers/openocd/jimtcl/tests/exec2.test Normal file
View File

@ -0,0 +1,47 @@
# These tests are design especially for the vfork() implementation
# of exec where sh -c must be used and thus we must take extra care
# in quoting arguments to exec.
source [file dirname [info script]]/testing.tcl
needs cmd exec
set d \"
set s '
set b \\
array set saveenv [array get env]
test exec2-1.1 "Quoting - Result" {
exec echo ${d}double quoted${d} ${s}single quoted${s} ${b}backslash quoted${b}
} "\"double\ quoted\"\ 'single quoted'\ \\backslash\ quoted\\"
test exec2-1.2 "Quoting - Word Grouping" {
string trim [exec echo ${d}double quoted${d} ${s}single quoted${s} ${b}backslash quoted${b} | wc -w]
} {6}
test exec2-2.1 "Add to exec environment" {
set env(TESTENV) "the value"
exec printenv | sed -n -e /^TESTENV=/p
} {TESTENV=the value}
test exec2-2.2 "Remove from exec environment" {
set env(TESTENV2) "new value"
unset env(TESTENV)
exec printenv | sed -n -e /^TESTENV=/p
} {}
test exec2-2.3 "Remove all exec environment" {
array unset env *
exec printenv | sed -n -e /^TESTENV2=/p
} {}
test exec2-2.4 "Remove all env var" {
unset -nocomplain env
exec printenv | sed -n -e /^TESTENV2=/p
} {}
array set env [array get saveenv]
testreport

79
debuggers/openocd/jimtcl/tests/exists.test Normal file
View File

@ -0,0 +1,79 @@
source [file dirname [info script]]/testing.tcl
needs cmd exists
testConstraint lambda [expr {[info commands lambda] ne {}}]
test exists-1.1 "Exists var" {
set a 1
exists a
} 1
test exists-1.1 "Exists var" {
unset -nocomplain b
exists b
} 0
test exists-1.1 "Exists -var" {
exists -var a
} 1
test exists-1.1 "Exists -var" {
exists -var b
} 0
test exists-1.1 "Exists in proc" {
proc a {name} { exists $name }
a ::a
} 1
test exists-1.1 "Exists in proc" {
a ::b
} 0
test exists-1.1 "Exists in proc" {
a name
} 1
test exists-1.1 "Exists in proc" {
a none
} 0
test exists-1.1 "Exists -proc" {
exists -proc a
} 1
test exists-1.1 "Exists -proc" {
exists -proc bogus
} 0
test exists-1.1 "Exists -proc" {
exists -proc info
} 0
test exists-1.1 "Exists -command" {
exists -command a
} 1
test exists-1.1 "Exists -command" {
exists -command info
} 1
test exists-1.1 "Exists -command" {
exists -command bogus
} 0
test exists-1.1 "Exists local lambda after exit" lambda {
proc a {} {
local lambda {} {dummy}
}
exists -proc [a]
} 0
test exists-1.1 "Exists local lambda" lambda {
proc a {} {
exists -proc [local lambda {} {dummy}]
}
a
} 1
testreport

3
debuggers/openocd/jimtcl/tests/exitpackage.tcl Normal file
View File

@ -0,0 +1,3 @@
# This package just exits
exit 1

27
debuggers/openocd/jimtcl/tests/expand.test Normal file
View File

@ -0,0 +1,27 @@
source [file dirname [info script]]/testing.tcl
test expand-1.1 "Basic tests" {
set a {1 2 3}
set b {4 5 6}
lappend a {*}$b
} {1 2 3 4 5 6}
test expand-1.2 "Basic tests" jim {
set a {1 2 3}
set b {4 5 6}
lappend a {expand}$b
} {1 2 3 4 5 6}
test expand-1.3 "Basic tests" {
set a {1 2 3}
set b {4 5 6}
lappend a *$b
} {1 2 3 {*4 5 6}}
test expand-1.4 "Basic tests" {
set a {1 2 3}
set b {4 5 6}
lappend a expand$b
} {1 2 3 {expand4 5 6}}
testreport

39
debuggers/openocd/jimtcl/tests/expr-base.test Normal file
View File

@ -0,0 +1,39 @@
source [file dirname [info script]]/testing.tcl
# Test number detection
set good_testcases {
0 0
1 1
8 8
00 0
07 7
08 8
0x5 5
0x0 0
0x00 0
-0x5 -5
0b111 7
-0b111 -7
-0B101 -5
0o7 7
}
set i 0
foreach {str exp} $good_testcases {
test expr-base-1.[incr i] "expr conversion" [list expr [list $str]] $exp
}
set bad_testcases {
{0x + 1}
x
0xx5
0x-5
{0x 5}
{0o8 + 1}
}
set i 0
foreach str $bad_testcases {
test expr-base-2.[incr i] "expr conversion failure" -returnCodes error -body [list expr $str] -match glob -result "*"
}
testreport

582
debuggers/openocd/jimtcl/tests/expr-new.test Normal file
View File

@ -0,0 +1,582 @@
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.9 2000/04/10 17:18:59 ericm Exp $
source [file dirname [info script]]/testing.tcl
# procedures used below
proc put_hello_char {c} {
global a
append a [format %c $c]
return $c
}
proc hello_world {} {
global a
set a ""
set L1 [set l0 [set h_1 [set q 0]]]
for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0]
:!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])]
?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3?
[incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]]
:[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2
?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]}
expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]}
}
set a
}
proc 12days {a b c} {
global xxx
expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \
[expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \
end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \
-94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9
:16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"]
:$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \
xxx [string index $c 31];scan [string index $c 31] %c x;set x]
:[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \
[string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a
?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0||
[12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \
"!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \
[string range $c 1 end]]}
}
proc do_twelve_days {} {
global xxx
set xxx ""
12days 1 1 1
string length $xxx
}
# start of tests
catch {unset a b i x}
test expr-1.1 {TclCompileExprCmd: no expression} {
list [catch {expr } msg]
} {1}
test expr-1.2 {TclCompileExprCmd: one expression word} {
expr -25
} -25
test expr-1.3 {TclCompileExprCmd: two expression words} {
expr -8.2 -6
} -14.2
test expr-1.4 {TclCompileExprCmd: five expression words} {
expr 20 - 5 +10 -7
} 18
test expr-1.5 {TclCompileExprCmd: quoted expression word} {
expr "0005"
} 5
test expr-1.6 {TclCompileExprCmd: quoted expression word} {
catch {expr "0005"zxy} msg
} {1}
test expr-1.7 {TclCompileExprCmd: expression word in braces} {
expr {-0005}
} -5
# XXX: I believe that this ought to return a string, thus -0x1234
#test expr-1.8 {TclCompileExprCmd: expression word in braces} {
# expr {{-0x1234}}
#} -4660
test expr-1.9 {TclCompileExprCmd: expression word in braces} {
catch {expr {-0005}foo} msg
} {1}
test expr-1.10 {TclCompileExprCmd: other expression word in braces} {
expr 4*[llength "6 2"]
} 8
test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} {
expr 4*[llength "6 2"];
} 8
test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} {
set a xxx
catch {
# Might not be a number
set a [expr 10*$a]
}
} 1
test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} {
set a xxx
set x 27; set bool {$x}; if $bool {set a foo}
set a
} foo
test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
set a xxx
set x 2; set b {$x}; set a [expr $b == 2]
set a
} 1
test expr-2.1 {TclCompileExpr: are builtin functions registered?} {
expr double(5*[llength "6 2"])
} 10.0
test expr-2.2 {TclCompileExpr: error in expr} {
catch {expr 2//3} msg
} {1}
test expr-2.3 {TclCompileExpr: junk after legal expr} {
catch {expr 7*[llength "a b"]foo} msg
} {1}
test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
expr {0001}
} 1
test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
test expr-3.2 {CompileCondExpr: error in lor expr} {
catch {expr x||3} msg
} {1}
test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test expr-3.4 {CompileCondExpr: error compiling true arm} {
catch {expr 3>2?2//3:66} msg
} {1}
test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test expr-3.6 {CompileCondExpr: error compiling false arm} {
catch {expr 2>3?44:2//3} msg
} {1}
if {0} {
test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {
puts "Note: doing test expr-3.7 which can take several minutes to run"
hello_world
} {Hello world}
catch {unset xxx}
test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {
puts "Note: doing test expr-3.8 which can take several minutes to run"
do_twelve_days
} 2358
catch {unset xxx}
}
test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
test expr-4.2 {CompileLorExpr: error in land expr} {
catch {expr x&&3} msg
} {1}
test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test expr-4.6 {CompileLorExpr: error compiling lor arm} {
catch {expr 2//3||4.0} msg
} {1}
test expr-4.7 {CompileLorExpr: error compiling lor arm} {
catch {expr 1.3||2//3} msg
} {1}
test expr-4.8 {CompileLorExpr: error compiling lor arms} {
list [catch {expr {"a"||"b"}} msg]
} {1}
test expr-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
test expr-5.2 {CompileLandExpr: error in bitor expr} {
catch {expr x|3} msg
} {1}
test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
test expr-5.7 {CompileLandExpr: error compiling land arm} {
catch {expr 2//3&&4.0} msg
} {1}
test expr-5.8 {CompileLandExpr: error compiling land arm} {
catch {expr 1.3&&2//3} msg
} {1}
test expr-5.9 {CompileLandExpr: error compiling land arm} {
list [catch {expr {"a"&&"b"}} msg]
} {1}
test expr-5.10 {CompileLandExpr: long land arms} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1
test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
test expr-6.2 {CompileBitXorExpr: error in bitand expr} {
catch {expr x|3} msg
} {1}
test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2//3|6} msg
} {1}
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2^x} msg
} {1}
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg]
} {1}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg]
} {1}
test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test expr-7.5 {CompileBitAndExpr: error in equality expr} {
catch {expr x==3} msg
} {1}
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2//3&6} msg
} {1}
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2&x} msg
} {1}
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg]
} {1}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg]
} {1}
test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test expr-8.5 {CompileEqualityExpr: error in relational expr} {
catch {expr x>3} msg
} {1}
test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
test expr-8.10 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2//3==6} msg
} {1}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2!=x} msg
} {1}
test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different
if {0x80000000 > 0} {
test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN (64bit)} jim {
expr {1<<63}
} -9223372036854775808
} else {
test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN (32bit)} jim {
expr {1<<31}
} -2147483648
}
test expr-9.6 {CompileRelationalExpr: error in shift expr} {
catch {expr x>>3} msg
} {1}
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test expr-9.9 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2//3>6} msg
} {1}
test expr-9.10 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2<x} msg
} {1}
test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -122
test expr-10.5 {CompileShiftExpr: error in add expr} {
catch {expr x+3} msg
} {1}
test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test expr-10.8 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2//3>>6} msg
} {1}
test expr-10.9 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2<<x} msg
} {1}
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg]
} {1}
test expr-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg]
} {1}
test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 19
test expr-11.5 {CompileAddExpr: error in multiply expr} {
catch {expr x*3} msg
} {1}
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} {
catch {expr 2//3+6} msg
} {1}
test expr-11.9 {CompileAddExpr: error compiling add arm} {
catch {expr 2-x} msg
} {1}
test expr-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg]
} {1}
test expr-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg]
} {1}
test expr-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg]
} {1}
test expr-11.13 {CompileAddExpr: divide by zero} {
expr {2.3/0.0}
} {Inf}
test expr-11.14 {CompileAddExpr: divide by zero} {
expr {-2.3/0.0}
} {-Inf}
test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
test expr-12.5 {CompileMultiplyExpr: error in unary expr} {
catch {expr ~x} msg
} {1}
test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*3%%6} msg
} {1}
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*x} msg
} {1}
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg]
} {1}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg]
} {1}
test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 123
test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} {
catch {expr ~x} msg
} {1}
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} {
catch {expr !1.x} msg
} {1}
test expr-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg]
} {1}
test expr-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg]
} {1}
test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test expr-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
test expr-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
} 27.0
test expr-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123
test expr-13.16 {CompileUnaryExpr: error in primary expr} {
catch {expr [set]} msg
} {1}
test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1
test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123
test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 10
test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0
test expr-14.6 {CompilePrimaryExpr: literal primary} {
expr 3.1400000
} 3.14
test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1
test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\
def} < {abcdef}}} 1
test expr-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0
test expr-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123
test expr-14.11 {CompilePrimaryExpr: var reference primary} {
set i 789
list [expr {$i}] [expr $i]
} {789 789}
test expr-14.12 {CompilePrimaryExpr: var reference primary} {
set i {789} ;# test expr's aggressive conversion to numeric semantics
list [expr {$i}] [expr $i]
} {789 789}
test expr-14.13 {CompilePrimaryExpr: var reference primary} {
catch {unset a}
set a(foo) foo
set a(bar) bar
set a(123) 123
set result ""
lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}]
catch {unset a}
set result
} {123 1}
test expr-14.14 {CompilePrimaryExpr: var reference primary} {
set i 123 ;# test "$var.0" floating point conversion hack
list [expr $i] [expr $i.0] [expr $i.0/12.0]
} {123 123.0 10.25}
test expr-14.15 {CompilePrimaryExpr: var reference primary} {
set i 123
catch {expr $i.2} msg
set msg
} 123.2
test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} {
catch {expr {$a(foo}} msg
} {1}
test expr-14.18 {CompilePrimaryExpr: quoted string primary} {
expr "21"
} 21
test expr-14.19 {CompilePrimaryExpr: quoted string primary} {
set i 123
set x 456
expr "$i+$x"
} 579
test expr-14.20 {CompilePrimaryExpr: quoted string primary} {
set i 3
set x 6
expr 2+"$i.$x"
} 5.6
test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} {
catch {expr "[set]"} msg
} {1}
test expr-14.22 {CompilePrimaryExpr: subcommand primary} {
expr {[set i 123; set i]}
} 123
test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set]}} msg
} {1}
test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set blah}} msg
} {1}
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
expr 2+(3*4)
} 14
test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} {
catch {expr 2+(3*[set])} msg
} {1}
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
catch {expr 2+(3*(4+5)} msg
} {1}
test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
set i "5+10"
list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15"
} {{15 == 15} {15 == 15} {15 == 15}}
test expr-14.32 {CompilePrimaryExpr: unexpected token} {
catch {expr @} msg
} {1}
test expr-15.2 {CompileMathFuncCall: unknown math function} {
catch {expr whazzathuh(1)} msg
} {1}
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
set i {}
}
set i
} {}
test expr-16.2 {GetToken: check for string literal in braces} {
expr {{1}}
} {1}
# Check "expr" and computed command names.
test expr-17.1 {expr and computed command names} {
set i 0
set z expr
$z 1+2
} 3
# Check correct conversion of operands to numbers: If the string looks like
# an integer, convert to integer. Otherwise, if the string looks like a
# double, convert to double.
test expr-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
} 11
test expr-18.2 {whitespace strings should not be == 0 (buggy strtod)} {
expr {" "}
} { }
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test expr-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
set dx 0.2
set f {$dx-$x/10}
set g {-$x/5}
set center 1.0
set x [expr $x-$center]
set dx [expr $dx+$g]
set x [expr $x+$f+$center]
set x [expr $x+$f+$center]
set y [expr round($x)]
}
p
} 3
catch {unset a}
# Test for incorrect "double evaluation" semantics
#XXX: Jim doesn't care about missing braces
#test expr-20.1 {wrong brace matching} {
# catch {unset l}
# catch {unset r}
# catch {unset q}
# catch {unset cmd}
# catch {unset a}
# set l "\{"; set r "\}"; set q "\""
# set cmd "expr $l$q|$q == $q$r$q$r"
# catch $cmd a
#} {1}
test expr-20.3 {broken substitution of integer digits} {
# fails with 8.0.x, but not 8.1b2
list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
} {4096 1000}
test expr-20.4 {proper double evaluation compilation, error case} {
catch {unset a}; # make sure $a doesn't exist
list [catch {expr 1?{$a}:0} msg]
} {1}
test expr-20.5 {proper double evaluation compilation, working case} {
set a yellow
expr 1?{$a}:0
} yellow
test expr-20.6 {handling of compile error in trial compile} {
list [catch {expr + {[incr]}} msg]
} {1}
test expr-20.7 {handling of compile error in runtime case} {
list [catch {expr + {[error foo]}} msg]
} {1}
# cleanup
if {[info exists a]} {
unset a
}
testreport

838
debuggers/openocd/jimtcl/tests/expr-old.test Normal file
View File

@ -0,0 +1,838 @@
# Commands covered: expr
#
# This file contains the original set of tests for Tcl's expr command.
# Since the expr command is now compiled, a new set of tests covering
# the new implementation are in the files "parseExpr.test and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.8.2.1 2002/04/18 13:10:27 msofer Exp $
source [file dirname [info script]]/testing.tcl
# First, test all of the integer operators individually.
test expr-old-1.1 {integer operators} {expr -4} -4
test expr-old-1.2 {integer operators} {expr -(1+4)} -5
test expr-old-1.3 {integer operators} {expr ~3} -4
test expr-old-1.4 {integer operators} {expr !2} 0
test expr-old-1.5 {integer operators} {expr !0} 1
test expr-old-1.6 {integer operators} {expr 4*6} 24
test expr-old-1.7 {integer operators} {expr 36/12} 3
test expr-old-1.8 {integer operators} {expr 27/4} 6
test expr-old-1.9 {integer operators} {expr 27%4} 3
test expr-old-1.10 {integer operators} {expr 2+2} 4
test expr-old-1.11 {integer operators} {expr 2-6} -4
test expr-old-1.12 {integer operators} {expr 1<<3} 8
test expr-old-1.13 {integer operators} {expr 0xff>>2} 63
test expr-old-1.14 {integer operators} {expr -1>>2} -1
test expr-old-1.15 {integer operators} {expr 3>2} 1
test expr-old-1.16 {integer operators} {expr 2>2} 0
test expr-old-1.17 {integer operators} {expr 1>2} 0
test expr-old-1.18 {integer operators} {expr 3<2} 0
test expr-old-1.19 {integer operators} {expr 2<2} 0
test expr-old-1.20 {integer operators} {expr 1<2} 1
test expr-old-1.21 {integer operators} {expr 3>=2} 1
test expr-old-1.22 {integer operators} {expr 2>=2} 1
test expr-old-1.23 {integer operators} {expr 1>=2} 0
test expr-old-1.24 {integer operators} {expr 3<=2} 0
test expr-old-1.25 {integer operators} {expr 2<=2} 1
test expr-old-1.26 {integer operators} {expr 1<=2} 1
test expr-old-1.27 {integer operators} {expr 3==2} 0
test expr-old-1.28 {integer operators} {expr 2==2} 1
test expr-old-1.29 {integer operators} {expr 3!=2} 1
test expr-old-1.30 {integer operators} {expr 2!=2} 0
test expr-old-1.31 {integer operators} {expr 7&0x13} 3
test expr-old-1.32 {integer operators} {expr 7^0x13} 20
test expr-old-1.33 {integer operators} {expr 7|0x13} 23
test expr-old-1.34 {integer operators} {expr 0&&1} 0
test expr-old-1.35 {integer operators} {expr 0&&0} 0
test expr-old-1.36 {integer operators} {expr 1&&3} 1
test expr-old-1.37 {integer operators} {expr 0||1} 1
test expr-old-1.38 {integer operators} {expr 3||0} 1
test expr-old-1.39 {integer operators} {expr 0||0} 0
test expr-old-1.40 {integer operators} {expr 3>2?44:66} 44
test expr-old-1.41 {integer operators} {expr 2>3?44:66} 66
test expr-old-1.42 {integer operators} {expr 36/5} 7
test expr-old-1.43 {integer operators} {expr 36%5} 1
test expr-old-1.44 {integer operators} {expr -36/5} -8
test expr-old-1.45 {integer operators} {expr -36%5} 4
test expr-old-1.46 {integer operators} {expr 36/-5} -8
test expr-old-1.47 {integer operators} {expr 36%-5} -4
test expr-old-1.48 {integer operators} {expr -36/-5} 7
test expr-old-1.49 {integer operators} {expr -36%-5} -1
test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
catch {unset x}
set x 1
list [expr {1 && $x}] [expr {$x && 1}] \
[expr {0 || $x}] [expr {$x || 0}]
} {1 1 1 1}
# Check the floating-point operators individually, along with
# automatic conversion to integers where needed.
test expr-old-2.1 {floating-point operators} {expr -4.2} -4.2
test expr-old-2.2 {floating-point operators} jim {expr -(1.1+4.2)} -5.3
test expr-old-2.3 {floating-point operators} {expr +5.7} 5.7
test expr-old-2.4 {floating-point operators} {expr +--+-62.0} -62.0
test expr-old-2.5 {floating-point operators} {expr !2.1} 0
test expr-old-2.6 {floating-point operators} {expr !0.0} 1
test expr-old-2.7 {floating-point operators} {expr 4.2*6.3} 26.46
test expr-old-2.8 {floating-point operators} {expr 36.0/12.0} 3.0
test expr-old-2.9 {floating-point operators} {expr 27/4.0} 6.75
test expr-old-2.10 {floating-point operators} {expr 2.3+2.1} 4.4
test expr-old-2.11 {floating-point operators} {expr 2.3-6.5} -4.2
test expr-old-2.12 {floating-point operators} {expr 3.1>2.1} 1
test expr-old-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0
test expr-old-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0
test expr-old-2.15 {floating-point operators} {expr 3.45<2.34} 0
test expr-old-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0
test expr-old-2.17 {floating-point operators} {expr 1.1<2.1} 1
test expr-old-2.18 {floating-point operators} {expr 3.1>=2.2} 1
test expr-old-2.19 {floating-point operators} {expr 2.345>=2.345} 1
test expr-old-2.20 {floating-point operators} {expr 1.1>=2.2} 0
test expr-old-2.21 {floating-point operators} {expr 3.0<=2.0} 0
test expr-old-2.22 {floating-point operators} {expr 2.2<=2.2} 1
test expr-old-2.23 {floating-point operators} {expr 2.2<=2.2001} 1
test expr-old-2.24 {floating-point operators} {expr 3.2==2.2} 0
test expr-old-2.25 {floating-point operators} {expr 2.2==2.2} 1
test expr-old-2.26 {floating-point operators} {expr 3.2!=2.2} 1
test expr-old-2.27 {floating-point operators} {expr 2.2!=2.2} 0
test expr-old-2.28 {floating-point operators} {expr 0.0&&0.0} 0
test expr-old-2.29 {floating-point operators} {expr 0.0&&1.3} 0
test expr-old-2.30 {floating-point operators} {expr 1.3&&0.0} 0
test expr-old-2.31 {floating-point operators} {expr 1.3&&3.3} 1
test expr-old-2.32 {floating-point operators} {expr 0.0||0.0} 0
test expr-old-2.33 {floating-point operators} {expr 0.0||1.3} 1
test expr-old-2.34 {floating-point operators} {expr 1.3||0.0} 1
test expr-old-2.35 {floating-point operators} {expr 3.3||0.0} 1
test expr-old-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3
test expr-old-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3
test expr-old-2.38 {floating-point operators} {
list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg]
} {1}
test expr-old-3.2 {illegal floating-point operations} {
list [catch {expr 27%4.0} msg]
} {1}
test expr-old-3.3 {illegal floating-point operations} {
list [catch {expr 27.0%4} msg]
} {1}
test expr-old-3.4 {illegal floating-point operations} {
list [catch {expr 1.0<<3} msg]
} {1}
test expr-old-3.5 {illegal floating-point operations} {
list [catch {expr 3<<1.0} msg]
} {1}
test expr-old-3.6 {illegal floating-point operations} {
list [catch {expr 24.0>>3} msg]
} {1}
test expr-old-3.7 {illegal floating-point operations} {
list [catch {expr 24>>3.0} msg]
} {1}
test expr-old-3.8 {illegal floating-point operations} {
list [catch {expr 24&3.0} msg]
} {1}
test expr-old-3.9 {illegal floating-point operations} {
list [catch {expr 24.0|3} msg]
} {1}
test expr-old-3.10 {illegal floating-point operations} {
list [catch {expr 24.0^3} msg]
} {1}
# Check the string operators individually.
test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0
test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0
test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1
test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1
test expr-old-4.5 {string operators} {expr {"abd" < "abd"}} 0
test expr-old-4.6 {string operators} {expr {"abe" < "abd"}} 0
test expr-old-4.7 {string operators} {expr {"abc" >= "def"}} 0
test expr-old-4.8 {string operators} {expr {"def" >= "def"}} 1
test expr-old-4.9 {string operators} {expr {"g" >= "def"}} 1
test expr-old-4.10 {string operators} {expr {"abc" <= "abd"}} 1
test expr-old-4.11 {string operators} {expr {"abd" <= "abd"}} 1
test expr-old-4.12 {string operators} {expr {"abe" <= "abd"}} 0
test expr-old-4.13 {string operators} {expr {"abc" == "abd"}} 0
test expr-old-4.14 {string operators} {expr {"abd" == "abd"}} 1
test expr-old-4.15 {string operators} {expr {"abc" != "abd"}} 1
test expr-old-4.16 {string operators} {expr {"abd" != "abd"}} 0
test expr-old-4.17 {string operators} {expr {"0y" < "0x12"}} 0
test expr-old-4.18 {string operators} {expr {"." < " "}} 0
# The following tests are non-portable because on some systems "+"
# and "-" can be parsed as numbers.
test expr-old-4.19 {string operators} {expr {"0" == "+"}} 0
test expr-old-4.20 {string operators} {expr {"0" == "-"}} 0
test expr-old-4.21 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.22 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg]
} {1}
test expr-old-5.2 {illegal string operations} {
list [catch {expr {+"a"}} msg]
} {1}
test expr-old-5.3 {illegal string operations} {
list [catch {expr {~"a"}} msg]
} {1}
test expr-old-5.4 {illegal string operations} {
list [catch {expr {!"a"}} msg]
} {1}
test expr-old-5.5 {illegal string operations} {
list [catch {expr {"a"*"b"}} msg]
} {1}
test expr-old-5.6 {illegal string operations} {
list [catch {expr {"a"/"b"}} msg]
} {1}
test expr-old-5.7 {illegal string operations} {
list [catch {expr {"a"%"b"}} msg]
} {1}
test expr-old-5.8 {illegal string operations} {
list [catch {expr {"a"+"b"}} msg]
} {1}
test expr-old-5.9 {illegal string operations} {
list [catch {expr {"a"-"b"}} msg]
} {1}
test expr-old-5.10 {illegal string operations} {
list [catch {expr {"a"<<"b"}} msg]
} {1}
test expr-old-5.11 {illegal string operations} {
list [catch {expr {"a">>"b"}} msg]
} {1}
test expr-old-5.12 {illegal string operations} {
list [catch {expr {"a"&"b"}} msg]
} {1}
test expr-old-5.13 {illegal string operations} {
list [catch {expr {"a"^"b"}} msg]
} {1}
test expr-old-5.14 {illegal string operations} {
list [catch {expr {"a"|"b"}} msg]
} {1}
test expr-old-5.15 {illegal string operations} {
list [catch {expr {"a"&&"b"}} msg]
} {1}
test expr-old-5.16 {illegal string operations} {
list [catch {expr {"a"||"b"}} msg]
} {1}
test expr-old-5.17 {illegal string operations} {
list [catch {expr {"a"?4:2}} msg]
} {1}
# Check precedence pairwise.
test expr-old-6.1 {precedence checks} {expr -~3} 4
test expr-old-6.2 {precedence checks} {expr -!3} 0
test expr-old-6.3 {precedence checks} {expr -~0} 1
test expr-old-7.1 {precedence checks} {expr 2*4/6} 1
test expr-old-7.2 {precedence checks} {expr 24/6*3} 12
test expr-old-7.3 {precedence checks} {expr 24/6/2} 2
test expr-old-8.1 {precedence checks} {expr -2+4} 2
test expr-old-8.2 {precedence checks} {expr -2-4} -6
test expr-old-8.3 {precedence checks} {expr +2-4} -2
test expr-old-9.1 {precedence checks} {expr 2*3+4} 10
test expr-old-9.2 {precedence checks} {expr 8/2+4} 8
test expr-old-9.3 {precedence checks} {expr 8%3+4} 6
test expr-old-9.4 {precedence checks} {expr 2*3-1} 5
test expr-old-9.5 {precedence checks} {expr 8/2-1} 3
test expr-old-9.6 {precedence checks} {expr 8%3-1} 1
test expr-old-10.1 {precedence checks} {expr 6-3-2} 1
test expr-old-11.1 {precedence checks} {expr 7+1>>2} 2
test expr-old-11.2 {precedence checks} {expr 7+1<<2} 32
test expr-old-11.3 {precedence checks} {expr 7>>3-2} 3
test expr-old-11.4 {precedence checks} {expr 7<<3-2} 14
test expr-old-12.1 {precedence checks} {expr 6>>1>4} 0
test expr-old-12.2 {precedence checks} {expr 6>>1<2} 0
test expr-old-12.3 {precedence checks} {expr 6>>1>=3} 1
test expr-old-12.4 {precedence checks} {expr 6>>1<=2} 0
test expr-old-12.5 {precedence checks} {expr 6<<1>5} 1
test expr-old-12.6 {precedence checks} {expr 6<<1<5} 0
test expr-old-12.7 {precedence checks} {expr 5<=6<<1} 1
test expr-old-12.8 {precedence checks} {expr 5>=6<<1} 0
test expr-old-13.1 {precedence checks} {expr 2<3<4} 1
test expr-old-13.2 {precedence checks} {expr 0<4>2} 0
test expr-old-13.3 {precedence checks} {expr 4>2<1} 0
test expr-old-13.4 {precedence checks} {expr 4>3>2} 0
test expr-old-13.5 {precedence checks} {expr 4>3>=2} 0
test expr-old-13.6 {precedence checks} {expr 4>=3>2} 0
test expr-old-13.7 {precedence checks} {expr 4>=3>=2} 0
test expr-old-13.8 {precedence checks} {expr 0<=4>=2} 0
test expr-old-13.9 {precedence checks} {expr 4>=2<=0} 0
test expr-old-13.10 {precedence checks} {expr 2<=3<=4} 1
test expr-old-14.1 {precedence checks} {expr 1==4>3} 1
test expr-old-14.2 {precedence checks} {expr 0!=4>3} 1
test expr-old-14.3 {precedence checks} {expr 1==3<4} 1
test expr-old-14.4 {precedence checks} {expr 0!=3<4} 1
test expr-old-14.5 {precedence checks} {expr 1==4>=3} 1
test expr-old-14.6 {precedence checks} {expr 0!=4>=3} 1
test expr-old-14.7 {precedence checks} {expr 1==3<=4} 1
test expr-old-14.8 {precedence checks} {expr 0!=3<=4} 1
test expr-old-15.1 {precedence checks} {expr 1==3==3} 0
test expr-old-15.2 {precedence checks} {expr 3==3!=2} 1
test expr-old-15.3 {precedence checks} {expr 2!=3==3} 0
test expr-old-15.4 {precedence checks} {expr 2!=1!=1} 0
test expr-old-16.1 {precedence checks} {expr 2&3==2} 0
test expr-old-16.2 {precedence checks} {expr 1&3!=3} 0
test expr-old-17.1 {precedence checks} {expr 7&3^0x10} 19
test expr-old-17.2 {precedence checks} {expr 7^0x10&3} 7
test expr-old-18.1 {precedence checks} {expr 7^0x10|3} 23
test expr-old-18.2 {precedence checks} {expr 7|0x10^3} 23
test expr-old-19.1 {precedence checks} {expr 7|3&&1} 1
test expr-old-19.2 {precedence checks} {expr 1&&3|7} 1
test expr-old-19.3 {precedence checks} {expr 0&&1||1} 1
test expr-old-19.4 {precedence checks} {expr 1||1&&0} 1
test expr-old-20.1 {precedence checks} {expr 1||0?3:4} 3
test expr-old-20.2 {precedence checks} {expr 1?0:4||1} 0
test expr-old-20.3 {precedence checks} {expr 1?2:0?3:4} 2
test expr-old-20.4 {precedence checks} {expr 0?2:0?3:4} 4
test expr-old-20.5 {precedence checks} {expr 1?2?3:4:0} 3
test expr-old-20.6 {precedence checks} {expr 0?2?3:4:0} 0
test expr-old-20.7 {precedence checks} {expr 0?1?1?2:3:0?4:5:1?0?6:7:0?8:9} 7
# Parentheses.
test expr-old-21.1 {parenthesization} {expr (2+4)*6} 36
test expr-old-21.2 {parenthesization} {expr (1?0:4)||1} 1
test expr-old-21.3 {parenthesization} {expr +(3-4)} -1
# Embedded commands and variable names.
set a 16
test expr-old-22.1 {embedded variables} {expr {2*$a}} 32
test expr-old-22.2 {embedded variables} {
set x -5
set y 10
expr {$x + $y}
} {5}
test expr-old-22.3 {embedded variables} {
set x " -5"
set y " +10"
expr {$x + $y}
} {5}
test expr-old-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2
test expr-old-22.5 {embedded commands and variables} {
list [catch {expr {12 - [bad_command_name]}} msg] $msg
} {1 {invalid command name "bad_command_name"}}
# Double-quotes and things inside them.
test expr-old-23.1 {double quotes} {expr {"abc"}} abc
test expr-old-23.2 {double quotes} {
set a 189
expr {"$a.bc"}
} 189.bc
test expr-old-23.3 {double quotes} {
set b2 xyx
expr {"$b2$b2$b2.[set b2].[set b2]"}
} xyxxyxxyx.xyx.xyx
test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22
test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc}
test expr-old-23.6 {double quotes} {
catch {unset bogus__}
list [catch {expr {"$bogus__"}} msg] $msg
} {1 {can't read "bogus__": no such variable}}
test expr-old-23.7 {double quotes} {
list [catch {expr {"a[error Testing]bc"}} msg] $msg
} {1 Testing}
test expr-old-23.8 {double quotes} {
list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg
} {0 1}
# Numbers in various bases.
test expr-old-24.1 {numbers in different bases} {expr 0x20} 32
test expr-old-24.2 {numbers in different bases} {expr 015} 15
# Conversions between various data types.
test expr-old-25.1 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.2 {type conversions} {expr 2.5+2} 4.5
test expr-old-25.3 {type conversions} {expr 2-2.5} -0.5
test expr-old-25.4 {type conversions} {expr 2/2.5} 0.8
test expr-old-25.5 {type conversions} {expr 2>2.5} 0
test expr-old-25.6 {type conversions} {expr 2.5>2} 1
test expr-old-25.7 {type conversions} {expr 2<2.5} 1
test expr-old-25.8 {type conversions} {expr 2>=2.5} 0
test expr-old-25.9 {type conversions} {expr 2<=2.5} 1
test expr-old-25.10 {type conversions} {expr 2==2.5} 0
test expr-old-25.11 {type conversions} {expr 2!=2.5} 1
test expr-old-25.12 {type conversions} {expr 2>"ab"} 0
test expr-old-25.13 {type conversions} {expr {2>" "}} 1
test expr-old-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1
test expr-old-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
test expr-old-25.16 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.17 {type conversions} {expr 2+2.5} 4.5
test expr-old-25.18 {type conversions} {expr 2.0e2} 200.0
test expr-old-25.19 {type conversions} {expr 2.0e30} 2e+30
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg]
} {1}
test expr-old-26.2 {error conditions} {
list [catch {expr 2+4*} msg]
} {1}
test expr-old-26.3 {error conditions} {
list [catch {expr 2+4*(} msg]
} {1}
catch {unset _non_existent_}
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg]
} {1}
set a xx
test expr-old-26.5 {error conditions} {
list [catch {expr {2+$a}} msg]
} {1}
test expr-old-26.6 {error conditions} {
list [catch {expr {2+[set a]}} msg]
} {1}
test expr-old-26.7 {error conditions} {
list [catch {expr {2+(4}} msg]
} {1}
test expr-old-26.8 {error conditions} {
list [catch {expr 2/0} msg]
} {1}
test expr-old-26.9 {error conditions} {
list [catch {expr 2%0} msg]
} {1}
test expr-old-26.10 {error conditions} {
expr 2.0/0.0
} {Inf}
test expr-old-26.11 {error conditions} {
list [catch {expr 2#} msg]
} {1}
test expr-old-26.12 {error conditions} {
list [catch {expr a.b} msg]
} {1}
test expr-old-26.13 {error conditions} {
list [catch {expr {"a"/"b"}} msg]
} {1}
test expr-old-26.14 {error conditions} {
list [catch {expr 2:3} msg]
} {1}
test expr-old-26.15 {error conditions} {
list [catch {expr a@b} msg]
} {1}
test expr-old-26.16 {error conditions} {
list [catch {expr a[b} msg]
} {1}
test expr-old-26.17 {error conditions} {
list [catch {expr a`b} msg]
} {1}
test expr-old-26.18 {error conditions} {
list [catch {expr \"a\"\{b} msg]
} {1}
test expr-old-26.19 {error conditions} {
list [catch {expr a} msg]
} {1}
test expr-old-26.20 {error conditions} {
list [catch expr msg]
} {1}
# Cancelled evaluation.
test expr-old-27.1 {cancelled evaluation} {
set a 1
expr {0&&[set a 2]}
set a
} 1
test expr-old-27.2 {cancelled evaluation} {
set a 1
expr {1||[set a 2]}
set a
} 1
test expr-old-27.3 {cancelled evaluation} {
set a 1
expr {0?[set a 2]:1}
set a
} 1
test expr-old-27.4 {cancelled evaluation} {
set a 1
expr {1?2:[set a 2]}
set a
} 1
catch {unset x}
test expr-old-27.5 {cancelled evaluation} {
list [catch {expr {[info exists x] && $x}} msg] $msg
} {0 0}
test expr-old-27.6 {cancelled evaluation} {
list [catch {expr {0 && [concat $x]}} msg] $msg
} {0 0}
test expr-old-27.7 {cancelled evaluation} {
set one 1
list [catch {expr {1 || 1/$one}} msg] $msg
} {0 1}
test expr-old-27.8 {cancelled evaluation} {
list [catch {expr {1 || -"string"}} msg] $msg
} {0 1}
test expr-old-27.9 {cancelled evaluation} {
list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg
} {0 1}
test expr-old-27.10 {cancelled evaluation} {
set x -1.3
list [catch {expr {($x > 0) ? round($x) : 0}} msg] $msg
} {0 0}
test expr-old-27.11 {cancelled evaluation} {
list [catch {expr {0 && foo}} msg]
} {1}
test expr-old-27.12 {cancelled evaluation} {
list [catch {expr {0 ? 1 : foo}} msg]
} {1}
# Operands enclosed in braces
#test expr-old-29.1 {braces} {expr {{abc}}} abc
#test expr-old-29.2 {braces} {expr {{00010}}} 8
#test expr-old-29.3 {braces} {expr {{3.1200000}}} 3.12
#test expr-old-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c"
#test expr-old-29.5 {braces} {
# list [catch {expr "\{abc"} msg] $msg
#} {1 {missing close-brace}}
# Very long values
test expr-old-30.1 {long values} {
set a "0000 1111 2222 3333 4444"
set a "$a | $a | $a | $a | $a"
set a "$a || $a || $a || $a || $a"
expr {$a}
} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444}
test expr-old-30.2 {long values} {
set a "000000000000000000000000000000"
set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5"
expr $a
} 5
# Expressions spanning multiple arguments
test expr-old-31.1 {multiple arguments to expr command} {
expr 4 + ( 6 *12) -3
} 73
test expr-old-31.2 {multiple arguments to expr command} {
list [catch {expr 2 + (3 + 4} msg]
} {1}
test expr-old-31.3 {multiple arguments to expr command} {
list [catch {expr 2 + 3 +} msg]
} {1}
test expr-old-31.4 {multiple arguments to expr command} {
list [catch {expr 2 + 3 )} msg]
} {1}
# Math functions
if {0} {
test expr-old-32.1 {math functions in expressions} {
format %.6g [expr acos(0.5)]
} {1.0472}
test expr-old-32.2 {math functions in expressions} {
format %.6g [expr asin(0.5)]
} {0.523599}
test expr-old-32.3 {math functions in expressions} {
format %.6g [expr atan(1.0)]
} {0.785398}
test expr-old-32.4 {math functions in expressions} {
format %.6g [expr atan2(2.0, 2.0)]
} {0.785398}
test expr-old-32.5 {math functions in expressions} {
format %.6g [expr ceil(1.999)]
} {2}
test expr-old-32.6 {math functions in expressions} {
format %.6g [expr cos(.1)]
} {0.995004}
test expr-old-32.7 {math functions in expressions} {
format %.6g [expr cosh(.1)]
} {1.005}
test expr-old-32.8 {math functions in expressions} {
format %.6g [expr exp(1.0)]
} {2.71828}
test expr-old-32.9 {math functions in expressions} {
format %.6g [expr floor(2.000)]
} {2}
test expr-old-32.10 {math functions in expressions} {
format %.6g [expr floor(2.001)]
} {2}
test expr-old-32.11 {math functions in expressions} {
format %.6g [expr fmod(7.3, 3.2)]
} {0.9}
test expr-old-32.12 {math functions in expressions} {
format %.6g [expr hypot(3.0, 4.0)]
} {5}
test expr-old-32.13 {math functions in expressions} {
format %.6g [expr log(2.8)]
} {1.02962}
test expr-old-32.14 {math functions in expressions} {
format %.6g [expr log10(2.8)]
} {0.447158}
test expr-old-32.15 {math functions in expressions} {
format %.6g [expr pow(2.1, 3.1)]
} {9.97424}
test expr-old-32.16 {math functions in expressions} {
format %.6g [expr sin(.1)]
} {0.0998334}
test expr-old-32.17 {math functions in expressions} {
format %.6g [expr sinh(.1)]
} {0.100167}
test expr-old-32.18 {math functions in expressions} {
format %.6g [expr sqrt(2.0)]
} {1.41421}
test expr-old-32.19 {math functions in expressions} {
format %.6g [expr tan(0.8)]
} {1.02964}
test expr-old-32.20 {math functions in expressions} {
format %.6g [expr tanh(0.8)]
} {0.664037}
}
test expr-old-32.21 {math functions in expressions} {
format %.6g [expr abs(-1.8)]
} {1.8}
test expr-old-32.22 {math functions in expressions} {
expr abs(10.0)
} {10.0}
test expr-old-32.23 {math functions in expressions} {
format %.6g [expr abs(-4)]
} {4}
test expr-old-32.24 {math functions in expressions} {
format %.6g [expr abs(66)]
} {66}
# The following test is different for 32-bit versus 64-bit architectures.
#test expr-old-32.25 {math functions in expressions} {
# list [catch {expr abs(0x8000000000000000)} msg] $msg
#} {1 {integer value too large to represent}}
test expr-old-32.26 {math functions in expressions} {
expr double(1)
} {1.0}
test expr-old-32.27 {math functions in expressions} {
expr double(1.1)
} {1.1}
test expr-old-32.28 {math functions in expressions} {
expr int(1)
} {1}
test expr-old-32.29 {math functions in expressions} {
expr int(1.4)
} {1}
test expr-old-32.30 {math functions in expressions} {
expr int(1.6)
} {1}
test expr-old-32.31 {math functions in expressions} {
expr int(-1.4)
} {-1}
test expr-old-32.32 {math functions in expressions} {
expr int(-1.6)
} {-1}
#test expr-old-32.33 {math functions in expressions} {
# list [catch {expr int(1e60)} msg] $msg
#} {1 {integer value too large to represent}}
#test expr-old-32.34 {math functions in expressions} {
# list [catch {expr int(-1e60)} msg] $msg
#} {1 {integer value too large to represent}}
test expr-old-32.35 {math functions in expressions} {
expr round(1.49)
} {1}
test expr-old-32.36 {math functions in expressions} {
expr round(1.51)
} {2}
test expr-old-32.37 {math functions in expressions} {
expr round(-1.49)
} {-1}
test expr-old-32.38 {math functions in expressions} {
expr round(-1.51)
} {-2}
#test expr-old-32.39 {math functions in expressions} {
# list [catch {expr round(1e60)} msg] $msg
#} {1 {integer value too large to represent}}
#test expr-old-32.40 {math functions in expressions} {
# list [catch {expr round(-1e60)} msg] $msg
#} {1 {integer value too large to represent}}
if {0} {
test expr-old-32.41 {math functions in expressions} {
list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg
} {0 16.0}
test expr-old-32.42 {math functions in expressions} {
list [catch {expr hypot(5*.8,3)} msg] $msg
} {0 5.0}
test expr-old-32.45 {math functions in expressions} {
expr (0 <= rand()) && (rand() < 1)
} {1}
test expr-old-32.46 {math functions in expressions} {
list [catch {expr rand(24)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-32.47 {math functions in expressions} {
list [catch {expr srand()} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-32.48 {math functions in expressions} {
list [catch {expr srand(3.79)} msg] $msg
} {1 {can't use floating-point value as argument to srand}}
test expr-old-32.49 {math functions in expressions} {
list [catch {expr srand("")} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.50 {math functions in expressions} {
set result [expr round(srand(12345) * 1000)]
for {set i 0} {$i < 10} {incr i} {
lappend result [expr round(rand() * 1000)]
}
set result
} {97 834 948 36 12 51 766 585 914 784 333}
test expr-old-32.51 {math functions in expressions} {
list [catch {expr {srand([lindex "6ty" 0])}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-33.1 {conversions and fancy args to math functions} {
expr hypot ( 3 , 4 )
} 5.0
test expr-old-33.2 {conversions and fancy args to math functions} {
expr hypot ( (2.0+1.0) , 4 )
} 5.0
test expr-old-33.3 {conversions and fancy args to math functions} {
expr hypot ( 3 , (3.0 + 1.0) )
} 5.0
test expr-old-33.4 {conversions and fancy args to math functions} {
format %.6g [expr cos(acos(0.1))]
} 0.1
test expr-old-34.1 {errors in math functions} {
list [catch {expr func_2(1.0)} msg] $msg
} {1 {unknown math function "func_2"}}
test expr-old-34.2 {errors in math functions} {
list [catch {expr func|(1.0)} msg] $msg
} {1 {syntax error in expression "func|(1.0)"}}
test expr-old-34.3 {errors in math functions} {
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-34.4 {errors in math functions} {
list [catch {expr hypot(1.0 2.0)} msg] $msg
} {1 {syntax error in expression "hypot(1.0 2.0)"}}
test expr-old-34.5 {errors in math functions} {
list [catch {expr hypot(1.0, 2.0} msg] $msg
} {1 {syntax error in expression "hypot(1.0, 2.0"}}
test expr-old-34.6 {errors in math functions} {
list [catch {expr hypot(1.0 ,} msg] $msg
} {1 {syntax error in expression "hypot(1.0 ,"}}
test expr-old-34.7 {errors in math functions} {
list [catch {expr hypot(1.0)} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-34.8 {errors in math functions} {
list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-34.9 {errors in math functions} {
list [catch {expr acos(-2.0)} msg] $msg $errorCode
} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}}
test expr-old-34.10 {errors in math functions} {
list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.11 {errors in math functions} {
list [catch {expr pow(3, 1000001)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.12 {errors in math functions} {
list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode
} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
test expr-old-34.13 {errors in math functions} {
list [catch {expr int(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.14 {errors in math functions} {
list [catch {expr int(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.15 {errors in math functions} {
list [catch {expr round(1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-34.16 {errors in math functions} {
list [catch {expr round(-1.0e30)} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test expr-old-36.1 {ExprLooksLikeInt procedure} {
list [catch {expr 0289} msg] $msg
} {1 {"0289" is an invalid octal number}}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0289
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
list [catch {expr 0289.1} msg] $msg
} {0 289.1}
test expr-old-36.4 {ExprLooksLikeInt procedure} {
set x 0289.1
list [catch {expr {$x+1}} msg] $msg
} {0 290.1}
test expr-old-36.5 {ExprLooksLikeInt procedure} {
set x { +22}
list [catch {expr {$x+1}} msg] $msg
} {0 23}
test expr-old-36.6 {ExprLooksLikeInt procedure} {
set x { -22}
list [catch {expr {$x+1}} msg] $msg
} {0 -21}
test expr-old-36.7 {ExprLooksLikeInt procedure} {
list [catch {expr nan} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-old-36.8 {ExprLooksLikeInt procedure} {
list [catch {expr 78e1} msg] $msg
} {0 780.0}
test expr-old-36.9 {ExprLooksLikeInt procedure} {
list [catch {expr 24E1} msg] $msg
} {0 240.0}
test expr-old-36.10 {ExprLooksLikeInt procedure} {
list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}
}
# test for [Bug #542588]
# XXX: Can't rely on overflow checking
#test expr-old-36.11 {ExprLooksLikeInt procedure} {
# # define a "too large integer"; this one works also for 64bit arith
# set x 665802003400000000000000
# list [catch {expr {$x+1}} msg] $msg
#} {1 {can't use integer value too large to represent as operand of "+"}}
# Special test for Pentium arithmetic bug of 1994:
if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
puts "that performs arithmetic incorrectly. I recommend that you"
puts "call Intel customer service immediately at 1-800-628-8686"
puts "to request a replacement processor."
puts [expr {(4195835.0 - (4195835.0/3145727.0)*3145727.0)}]
}
if {0.0 == 256.0} {
puts error
}
testreport

138
debuggers/openocd/jimtcl/tests/expr.test Normal file
View File

@ -0,0 +1,138 @@
source [file dirname [info script]]/testing.tcl
test expr-1.1 "Compare strings lt" {
expr {"V000500" < "V000405"}
} {0}
test expr-1.2 "Compare strings with embedded nulls" {
set s1 [format abc%cdef 0]
set s2 [format abc%cghi 0]
expr {$s1 < $s2}
} {1}
test expr-1.3 "Hex values" {
set mask1 [expr 0x4050 & 0x0CCC]
} {64}
test expr-1.4 "Ternary operator - true" {
expr {1 ? 2 : 3}
} {2}
test expr-1.5 "Ternary operator - false" {
expr {0 ? 2 : 3}
} {3}
test expr-1.6 "Ternary operator - double check" {
expr {1.0 ? 2 : 3}
} {2}
test expr-1.7 "Ternary operator - string result" {
expr {1 ? "two" : 3}
} {two}
test expr-1.8 "Ternary operator - don't eval false path" {
set a 100
set b 200
set c [expr {20 ? [incr a] : [incr b]}]
list $a $b $c
} {101 200 101}
test expr-1.9 "Unary minus" {
set a 1
expr {-$a}
} {-1}
test expr-1.10 "Subtraction" {
set a 1
set b 10
expr {$b-$a}
} {9}
test expr-1.11 "Short circuit evaluation" {
set a 100
set c [expr {0 || [incr a]}]
list $a $c
} {101 1}
test expr-1.12 "Short circuit evaluation" {
set a 100
set c [expr {1 || [incr a]}]
list $a $c
} {100 1}
test expr-1.13 "Short circuit evaluation" {
set a 100
set c [expr {1 || [incr a] && [incr a]}]
list $a $c
} {100 1}
test expr-1.14 "Rotate left" jim {
expr {1 <<< 5}
} {32}
test expr-1.15 "Rotate left" jim {
expr {1 <<< 65}
} {2}
test expr-1.16 "Rotate right" jim {
expr {1 >>> 48}
} {65536}
test expr-1.17 "Rotate left" jim {
expr {1 >>> 63}
} {2}
# This crashes older jim
test expr-2.1 "bogus unarymin" {
catch {expr {unarymin 1}}
return 1
} {1}
test expr-2.2 "Ternary operator - missing colon" {
list [catch {expr {1 ? 2 3}} msg]
} {1}
test expr-2.3 "Ternary operator - missing third term" {
list [catch {expr {1 ? 2}} msg]
} {1}
test expr-2.4 "Ternary operator - missing question" {
list [catch {expr {1 : 2}} msg]
} {1}
test expr-3.1 "in, ni operators" {
set l {a b c d}
set c C
list [expr {"a" in $l}] [expr {$c in $l}] [expr {"b" ni $l}] [expr {$c ni $l}]
} {1 0 0 1}
test expr-3.2 "if: in, ni operators" {
set l {a b c d}
set a a
set c C
set result {}
if {$a in $l} {
lappend result 1
}
if {$c in $l} {
lappend result 2
}
if {$a ni $l} {
lappend result 3
}
if {$c ni $l} {
lappend result 4
}
if {"d" in $l} {
lappend result 5
}
} {1 4 5}
# Don't want a to become 2.0
test expr-4.1 "Shimmering" {
set a 2
expr {$a < 3.0}
set a
} {2}
testreport

52
debuggers/openocd/jimtcl/tests/exprsugar.test Normal file
View File

@ -0,0 +1,52 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim
# Test the expr-sugar syntax: $(...)
test exprsugar-1.1 {Simple operations} {
set x $(2)
} 2
test exprsugar-1.2 {Simple operations} {
set x $(-3)
} -3
test exprsugar-1.3 {Simple operations} {
set x $(!0)
} 1
test exprsugar-1.4 {Simple operations} {
set a 3
set x $($a)
} 3
test exprsugar-1.5 {Simple operations} {
set x $($a + 4)
} 7
test exprsugar-1.6 {Simple operations} {
set x $(6 * 7 + 2)
} 44
test exprsugar-1.7 {Simple operations} {
set a bb
set x $($a in {aa bb cc})
} 1
test exprsugar-1.8 {Simple operations} {
set a 1
set x $($a ? "yes" : "no")
} yes
test exprsugar-1.9 {Simple operations} {
set a 1
set x $([incr a])
list $a $x
} {2 2}
# expr sugar inside an expression is an error
test exprsugar-1.10 {Simple operations} {
catch {set x $(1 + $(5 * 7))}
} 1
test exprsugar-1.11 {Simple operations} {
unset a
set a(b) 3
set x $(2 + $a(b))
} 5
test exprsugar-1.12 {Simple operations} {
set x $((2 + 4))
} 6
testreport

69
debuggers/openocd/jimtcl/tests/filecopy.test Normal file
View File

@ -0,0 +1,69 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd file
needs cmd exec
needs cmd parray tclcompat
cd $testdir
file mkdir tempdir
test filecopy-1.1 "Simple case" {
file copy testio.in tempfile
} {}
test filecopy-1.2 "Target exists" {
list [catch {file copy testio.in tempfile} msg] $msg
} {1 {error copying "testio.in" to "tempfile": file already exists}}
test filecopy-1.3 "Source doesn't exist" {
list [catch {file copy missing tempfile} msg] $msg
} {1 {missing: No such file or directory}}
test filecopy-1.4 "Can't write to target" {
list [catch {file copy testio.in tempdir} msg] $msg
} {1 {error copying "testio.in" to "tempdir": file already exists}}
test filecopy-1.5 "Source doesn't exist and can't write to target" {
list [catch {file copy missing tempdir} msg] $msg
} {1 {missing: No such file or directory}}
test filecopy-1.6 "Wrong args" {
list [catch {file copy onearg} msg] $msg
} {1 {wrong # args: should be "file copy ?-force? source dest"}}
test filecopy-1.7 "Wrong args" {
list [catch {file copy too many args here} msg] $msg
} {1 {wrong # args: should be "file copy ?-force? source dest"}}
test filecopy-1.8 "Wrong args" {
list [catch {file copy -blah testio.in tempfile} msg] $msg
} {1 {bad option "-blah": should be -force}}
file delete tempfile
test filecopy-2.1 "Simple case (-force)" {
file copy -force testio.in tempfile
} {}
test filecopy-2.2 "Target exists (-force)" {
file copy -force testio.in tempfile
} {}
test filecopy-2.3 "Source doesn't exist (-force)" {
list [catch {file copy -force missing tempfile} msg] $msg
} {1 {missing: No such file or directory}}
test filecopy-2.4 "Can't write to target (-force)" -body {
file copy -force testio.in tempdir
} -returnCodes error -match glob -result {tempdir: *}
test filecopy-2.5 "Source doesn't exist and can't write to target (-force)" {
list [catch {file copy -force missing tempdir} msg] $msg
} {1 {missing: No such file or directory}}
file delete tempfile
exec rm -rf tempdir
testreport

68
debuggers/openocd/jimtcl/tests/filedir.test Normal file
View File

@ -0,0 +1,68 @@
source [file dirname [info script]]/testing.tcl
needs cmd file
needs cmd exec
catch {
exec rm -rf tmp
exec mkdir tmp
exec touch tmp/file
exec mkdir tmp/dir
}
test mkdir-1.1 "Simple dir" {
file mkdir tmp/abc
file isdir tmp/abc
} {1}
test mkdir-1.2 "Create missing parents" {
file mkdir tmp/def/ghi/jkl
file isdir tmp/def/ghi/jkl
} {1}
test mkdir-1.3 "Existing dir" {
file mkdir tmp/dir
file isdir tmp/dir
} {1}
test mkdir-1.4 "Child of existing dir" {
file mkdir tmp/dir/child
file isdir tmp/dir/child
} {1}
test mkdir-1.5 "Create dir over existing file" {
list [catch {file mkdir tmp/file} msg] [file isdir tmp/file]
} {1 0}
test mkdir-1.6 "Create dir below existing file" {
list [catch {file mkdir tmp/file/dir} msg] [file isdir tmp/file/dir]
} {1 0}
test mkdir-1.8 "Multiple dirs" {
file mkdir tmp/1 tmp/2 tmp/3
list [file isdir tmp/1] [file isdir tmp/2] [file isdir tmp/3]
} {1 1 1}
test mkdir-1.7 "Stop on failure" {
catch {file mkdir tmp/4 tmp/file tmp/5}
list [file isdir tmp/4] [file isdir tmp/5]
} {1 0}
test rmdir-2.0 "Remove existing dir" {
file delete tmp/1
file isdir tmp/1
} {0}
test rmdir-2.1 "Remove missing dir" {
file delete tmp/1
} {}
test rmdir-2.2 "Remove non-empty dir" {
catch {file delete tmp/def}
} {1}
catch {
exec rm -rf tmp
}
testreport

84
debuggers/openocd/jimtcl/tests/filejoin.test Normal file
View File

@ -0,0 +1,84 @@
source [file dirname [info script]]/testing.tcl
needs cmd file
test join-1.1 "One name" {
file join abc
} {abc}
test join-1.2 "One name with trailing slash" {
file join abc/
} {abc}
test join-1.3 "One name with leading slash" {
file join /abc
} {/abc}
test join-1.4 "One name with leading and trailing slash" {
file join /abc/
} {/abc}
test join-1.5 "Two names" {
file join abc def
} {abc/def}
test join-1.6 "Two names with dir trailing slash" {
file join abc/ def
} {abc/def}
test join-1.7 "Two names with dir leading slash" {
file join /abc def
} {/abc/def}
test join-1.8 "Two names with dir leading and trailing slash" {
file join /abc/ def
} {/abc/def}
test join-1.9 "Two names with file trailing slash" {
file join abc def/
} {abc/def}
test join-1.10 "Two names with file leading slash" {
file join abc /def
} {/def}
test join-1.11 "Two names with file leading and trailing slash" {
file join abc /def/
} {/def}
test join-1.12 "Two names with double slashes" {
file join abc/ /def
} {/def}
test join-1.13 "Join to root" {
file join / abc
} {/abc}
test join-1.14 "Join to root" {
set dir [file join / .]
# Either / or /. is OK here
expr {$dir in {/ /.}}
} 1
test join-1.15 "Join to root" {
file join / /
} {/}
test join-1.16 "Join to root" {
file join /abc /
} {/}
test join-2.1 "Dir is empty string" {
file join "" def
} {def}
test join-2.2 "File is empty string" {
file join abc ""
} {abc}
test join-2.3 "Path too long" jim {
set components [string repeat {abcdefghi } 500]
list [catch [concat file join $components] msg] $msg
} {1 {Path too long}}
testreport

66
debuggers/openocd/jimtcl/tests/for.test Normal file
View File

@ -0,0 +1,66 @@
# Commands covered: for, continue, break
#
# This file contains the original set of tests for Tcl's for command.
# Since the for command is now compiled, a new set of tests covering
# the new implementation is in the file "for.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: for-old.test,v 1.5 2000/04/10 17:18:59 ericm Exp $
source [file dirname [info script]]/testing.tcl
# Check "for" and its use of continue and break.
catch {unset a i}
test for-old-1.1 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
set a [concat $a $i]
}
set a
} {1 2 3 4 5}
test for-old-1.2 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==4 continue
set a [concat $a $i]
}
set a
} {1 2 3 5}
test for-old-1.3 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]} {
if $i==4 break
set a [concat $a $i]
}
set a
} {1 2 3}
test for-old-1.4 {for tests} {catch {for 1 2 3} msg} 1
test for-old-1.5 {for tests} {
catch {for 1 2 3} msg
} {1}
test for-old-1.6 {for tests} {catch {for 1 2 3 4 5} msg} 1
test for-old-1.7 {for tests} {
catch {for 1 2 3 4 5} msg
} {1}
test for-old-1.8 {for tests} {
set a {xyz}
for {set i 1} {$i<6} {set i [expr $i+1]} {}
set a
} xyz
test for-old-1.9 {for tests} {
set a {}
for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
set a [concat $a $i]
}
set a
} {1 2 3}
testreport

501
debuggers/openocd/jimtcl/tests/format.test Normal file
View File

@ -0,0 +1,501 @@
# Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.8 2000/04/10 17:18:59 ericm Exp $
source [file dirname [info script]]/testing.tcl
needs cmd format
# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail. Someday I hope this code shouldn't be necessary (code added
# 9/9/91).
set roundOffBug 0
if {"[format %7.1e 68.514]" == "6.8e+01"} {
puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n"
set roundOffBug 1
}
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
} { 6 34 16923 -12 -1 0xe 0XC}
# %u output depends on word length, so this test is not portable.
test format-1.3 {integer formatting} {
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} { 6 34 16923 18446744073709551604 -1 0}
test format-1.4 {integer formatting} {
format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1
} {6 34 16923 -12 }
test format-1.5 {integer formatting} {
format "%04d %04d %04d %04i" 6 34 16923 -12 -1
} {0006 0034 16923 -012}
test format-1.6 {integer formatting} {
format "%00*d" 6 34
} {000034}
# Printing negative numbers in hex or octal format depends on word
# length, so these tests are not portable.
test format-1.7 {integer formatting} {
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} { 6 22 421b fffffffffffffff4}
test format-1.8 {integer formatting} {
format "%#x %#X %#X %#x" 6 34 16923 -12 -1
} {0x6 0X22 0X421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} {
format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
} { 0x6 0x22 0x421b 0xfffffffffffffff4}
test format-1.10 {integer formatting} {
format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
} {0x6 0x22 0x421b 0xfffffffffffffff4 }
test format-1.11 {integer formatting} {
format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
} {06 042 041033 01777777777777777777764}
test format-1.12 {no sign extend large 32 bit values} {
format %x 0xa0000000
} {a0000000}
test format-2.1 {string formatting} {
format "%s %s %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. x x}
test format-2.2 {string formatting} {
format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
} { abcd This is a very long test string. x x}
test format-2.3 {string formatting} {
format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x
} {abcd This is a x x}
test format-2.4 {string formatting} {
format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. % x x}
test format-2.5 {string formatting, embedded nulls} {
format "%10s" abc\0def
} " abc\0def"
test format-2.6 {string formatting, international chars} utf8 {
format "%10s" abc\ufeffdef
} " abc\ufeffdef"
test format-2.6 {string formatting, international chars} utf8 {
format "%.5s" abc\ufeffdef
} "abc\ufeffd"
test format-2.7 {string formatting, international chars} {
format "foo\ufeffbar%s" baz
} "foo\ufeffbarbaz"
test format-2.8 {string formatting, width} {
format "a%5sa" f
} "a fa"
test format-2.8 {string formatting, width} {
format "a%-5sa" f
} "af a"
test format-2.8 {string formatting, width} {
format "a%2sa" foo
} "afooa"
test format-2.8 {string formatting, width} {
format "a%0sa" foo
} "afooa"
test format-2.8 {string formatting, precision} {
format "a%.2sa" foobarbaz
} "afoa"
test format-2.8 {string formatting, precision} {
format "a%.sa" foobarbaz
} "aa"
test format-2.8 {string formatting, precision} {
list [catch {format "a%.-2sa" foobarbaz} msg] $msg
} {1 {bad field specifier "-"}}
test format-2.8 {string formatting, width and precision} {
format "a%5.2sa" foobarbaz
} "a foa"
test format-2.8 {string formatting, width and precision} {
format "a%5.7sa" foobarbaz
} "afoobarba"
test format-3.1 {Tcl_FormatObjCmd: character formatting} utf8 {
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65
} "|A|A|A|A|A | A| A|A |"
test format-3.2 {Tcl_FormatObjCmd: international character formatting} utf8 {
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f
} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |"
test format-4.1 {e and f formats} -body {
format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
} -match regexp -result {3.420000e\+0?13 6.851400e\+0?01 -1.250000e-0?01 -1.600000e\+0?04}
test format-4.2 {e and f formats} -body {
format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
} -match regexp -result {( 3.420000e\+13 6.851400e\+01 -1.250000e-01 -1.600000e\+04| 3.420000e\+013 6.851400e\+001 -1.250000e-001 -1.600000e\+004)}
test format-4.3 {e and f formats} -body {
format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
} -match regexp -result {3.4e\+0?13 6.9e\+0?01 -1.3e-0?01 -1.6e\+0?04}
test format-4.4 {e and f formats} -body {
format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
} -match regexp -result {(000000003.420000e\+13 000000006.851400e\+01 -00000001.260000e-01 -00000001.600000e\+04|00000003.420000e\+013 00000006.851400e\+001 -0000001.260000e-001 -0000001.600000e\+004)}
test format-4.5 {e and f formats} -body {
format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
} -match regexp -result {3.4e\+0?13 6.9e\+0?01 -1.3e-0?01 -1.6e\+0?04}
test format-4.6 {e and f formats} {
format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.000000 68.514000 -0.125000 -16000.000000}
test format-4.7 {e and f formats} {
format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
test format-4.8 {e and f formats} -body {
format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
} -match regexp -result {\-1.0000e\+0?01 -9.99996e\+0?00 9.999960e\+0?00}
test format-4.9 {e and f formats} {
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
} {-10.0000 -9.99996 9.999960}
test format-4.10 {e and f formats} {
format "%20f %-20f %020f" -9.99996 -9.99996 9.99996
} { -9.999960 -9.999960 0000000000009.999960}
test format-4.11 {e and f formats} {
format "%-020f %020f" -9.99996 -9.99996 9.99996
} {-9.999960 -000000000009.999960}
test format-4.12 {e and f formats} -body {
format "%.0e %#.0e" -9.99996 -9.99996 9.99996
} -match regexp -result {\-1e\+0?01 -1.e\+0?01}
test format-4.13 {e and f formats} {
format "%.0f %#.0f" -9.99996 -9.99996 9.99996
} {-10 -10.}
test format-4.14 {e and f formats} {
format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
} {-10.0000 -9.99996 9.999960}
test format-4.15 {e and f formats} {
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
} { 1 1 1 1}
test format-4.16 {e and f formats} {
format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
} {0.0 0.1 0.0 0.0}
test format-5.1 {g-format} -body {
format "%.3g" 12341.0
} -match regexp -result {1.23e\+0?04}
test format-5.2 {g-format} -body {
format "%.3G" 1234.12345
} -match regexp -result {1.23E\+0?03}
test format-5.3 {g-format} {
format "%.3g" 123.412345
} {123}
test format-5.4 {g-format} {
format "%.3g" 12.3412345
} {12.3}
test format-5.5 {g-format} {
format "%.3g" 1.23412345
} {1.23}
test format-5.6 {g-format} {
format "%.3g" 1.23412345
} {1.23}
test format-5.7 {g-format} {
format "%.3g" .123412345
} {0.123}
test format-5.8 {g-format} {
format "%.3g" .012341
} {0.0123}
test format-5.9 {g-format} {
format "%.3g" .0012341
} {0.00123}
test format-5.10 {g-format} {
format "%.3g" .00012341
} {0.000123}
test format-5.11 {g-format} -body {
format "%.3g" .00001234
} -match regexp -result {1.23e-0?05}
test format-5.12 {g-format} -body {
format "%.4g" 9999.6
} -match regexp -result {1e\+0?04}
test format-5.13 {g-format} {
format "%.4g" 999.96
} {1000}
test format-5.14 {g-format} {
format "%.3g" 1.0
} {1}
test format-5.15 {g-format} {
format "%.3g" .1
} {0.1}
test format-5.16 {g-format} {
format "%.3g" .01
} {0.01}
test format-5.17 {g-format} {
format "%.3g" .001
} {0.001}
test format-5.18 {g-format} -body {
format "%.3g" .00001
} -match regexp -result {1e-0?05}
test format-5.19 {g-format} -body {
format "%#.3g" 1234.0
} -match regexp -result {1.23e\+0?03}
test format-5.20 {g-format} -body {
format "%#.3G" 9999.5
} -match regexp -result {1.00E\+0?04}
test format-6.1 {floating-point zeroes} -body {
format "%e %f %g" 0.0 0.0 0.0 0.0
} -match regexp -result {0.000000e\+0?00 0.000000 0}
test format-6.2 {floating-point zeroes} -body {
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
} -match regexp -result {0.0000e\+0?00 0.0000 0}
test format-6.3 {floating-point zeroes} -body {
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
} -match regexp -result {0.0000e\+0?00 0.0000 0.000}
test format-6.4 {floating-point zeroes} -body {
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
} -match regexp -result {0e\+0?00 0 0}
test format-6.5 {floating-point zeroes} -body {
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
} -match regexp -result {0.e\+0?00 0. 0.}
test format-6.6 {floating-point zeroes} {
format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0
} { 0 0 0 0}
test format-6.7 {floating-point zeroes} {
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
} { 1 1 1 1}
test format-6.8 {floating-point zeroes} {
format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
} {0.0 0.1 0.0 0.0}
test format-7.1 {various syntax features} {
format "%*.*f" 12 3 12.345678901
} { 12.346}
test format-7.2 {various syntax features} {
format "%0*.*f" 12 3 12.345678901
} {00000012.346}
test format-7.3 {various syntax features} {
format "\*\t\\n"
} {* \n}
test format-8.1 {error conditions} {
catch format
} 1
test format-8.2 {error conditions} jim {
catch format msg
set msg
} {wrong # args: should be "format formatString ?arg arg ...?"}
test format-8.3 {error conditions} {
catch {format %*d}
} 1
test format-8.4 {error conditions} {
catch {format %*d} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.5 {error conditions} {
catch {format %*.*f 12}
} 1
test format-8.6 {error conditions} {
catch {format %*.*f 12} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.7 {error conditions} {
catch {format %*.*f 12 3}
} 1
test format-8.8 {error conditions} {
catch {format %*.*f 12 3} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.9 {error conditions} {
list [catch {format %*d x 3} msg] $msg
} {1 {expected integer but got "x"}}
test format-8.10 {error conditions} {
list [catch {format %*.*f 2 xyz 3} msg] $msg
} {1 {expected integer but got "xyz"}}
test format-8.11 {error conditions} {
catch {format %d 2a}
} 1
test format-8.12 {error conditions} {
catch {format %d 2a} msg
set msg
} {expected integer but got "2a"}
test format-8.13 {error conditions} {
catch {format %c 2x}
} 1
test format-8.14 {error conditions} {
catch {format %c 2x} msg
set msg
} {expected integer but got "2x"}
test format-8.15 {error conditions} {
catch {format %f 2.1z}
} 1
test format-8.16 {error conditions} jim {
catch {format %f 2.1z} msg
set msg
} {expected number but got "2.1z"}
test format-8.17 {error conditions} {
catch {format ab%}
} 1
test format-8.18 {error conditions} {
catch {format ab% 12} msg
set msg
} {format string ended in middle of field specifier}
test format-8.19 {error conditions} {
catch {format %q x}
} 1
test format-8.20 {error conditions} {
catch {format %q x} msg
set msg
} {bad field specifier "q"}
test format-8.21 {error conditions} {
catch {format %d}
} 1
test format-8.22 {error conditions} {
catch {format %d} msg
set msg
} {not enough arguments for all format specifiers}
test format-8.23 {error conditions} {
catch {format "%d %d" 24 xyz} msg
set msg
} {expected integer but got "xyz"}
test format-9.1 {long result} {
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s} $a $a
} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
test format-10.1 {"h" format specifier} {
format %hd 0xffff
} -1
test format-10.2 {"h" format specifier} {
format %hx 0x10fff
} fff
test format-10.3 {"h" format specifier} {
format %hd 0x10000
} 0
test format-11.1 {XPG3 %$n specifiers} {
format {%2$d %1$d} 4 5
} {5 4}
test format-11.2 {XPG3 %$n specifiers} {
format {%2$d %1$d %1$d %3$d} 4 5 6
} {5 4 4 6}
test format-11.3 {XPG3 %$n specifiers} {
list [catch {format {%2$d %3$d} 4 5} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.4 {XPG3 %$n specifiers} {
list [catch {format {%2$d %0$d} 4 5 6} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.5 {XPG3 %$n specifiers} {
list [catch {format {%d %1$d} 4 5 6} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test format-11.6 {XPG3 %$n specifiers} {
list [catch {format {%2$d %d} 4 5 6} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test format-11.7 {XPG3 %$n specifiers} {
list [catch {format {%2$d %3d} 4 5 6} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test format-11.8 {XPG3 %$n specifiers} {
format {%2$*d %3$d} 1 10 4
} { 4 4}
test format-11.9 {XPG3 %$n specifiers} {
format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44
} {abcde 44}
test format-11.10 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.11 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5} msg] $msg
} {1 {"%n$" argument index out of range}}
test format-11.12 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5 6} msg] $msg
} {0 { 6}}
test format-12.1 {negative width specifiers} {
format "%*d" -47 25
} {25 }
test format-13.1 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
set a 0.0000000000001
set b 0.00000000000001
set c 0.00000000000000001
set d [expr $a + $b + $c]
format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
} {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001}
test format-13.2 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
set a 0.000000000001
set b 0.000000000000005
set c 0.0000000000000008
set d [expr $a + $b + $c]
format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d
} {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580}
test format-13.3 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
set a 0.00000000000099
set b 0.000000000000011
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c
} {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100}
test format-13.4 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
set a 0.444444444444
set b 0.33333333333333
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c
} {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300}
test format-13.5 {tcl_precision fuzzy comparison} {
catch {unset a}
catch {unset b}
catch {unset c}
set a 0.444444444444
set b 0.99999999999999
set c [expr $a + $b]
format {%0.10f %0.12f %0.15f} $c $c $c
} {1.4444444444 1.444444444444 1.444444444443990}
test format-14.1 {testing MAX_FLOAT_SIZE for 0 and 1} {
format {%s} ""
} {}
test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} {
format {%s} "a"
} {a}
test format-15.1 {testing %0..s 0 padding for chars/strings} {
format %05s a
} {0000a}
test format-15.2 {testing %0..s 0 padding for chars/strings} {
format "% 5s" a
} { a}
test format-15.3 {testing %0..s 0 padding for chars/strings} {
format %5s a
} { a}
test format-15.4 {testing %0..s 0 padding for chars/strings} {
format %05c 61
} {0000=}
set a "0123456789"
set b ""
for {set i 0} {$i < 290} {incr i} {
append b $a
}
for {set i 290} {$i < 400} {incr i} {
test format-15.[expr $i -290] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
testreport

131
debuggers/openocd/jimtcl/tests/glob.test Normal file
View File

@ -0,0 +1,131 @@
# Test the glob command
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd glob
# Fake the bare minimum that glob.tcl needs:
# [readdir], [file isdir] and [file exists]
local proc file {cmd args} {
if {$cmd in {isdir exists}} {
lassign [fslookup [lindex $args 0]] type contents
if {$cmd eq "isdir" && $type eq "dir"} {
return 1
} elseif {$type ne "none"} {
return 1
}
return 0
}
tailcall upcall file $cmd {*}$args
}
local proc readdir {{-nocomplain {}} dir} {
lassign [fslookup $dir] type contents
if {$type ne "dir"} {
if {${-nocomplain} eq ""} {
return {}
}
return -code error "No such file or directory"
}
dict keys $contents
}
local proc fslookup {path} {
set type dir
set dict $::FAKEFS
foreach p [split $path /] {
if {$p in {. {}}} {
continue
}
if {![dict exists $dict $p] || $type ne "dir"} {
return none
}
lassign [dict get $dict $p] type dict
}
list $type $dict
}
# Creates the representation of a filesystem in a dictionary - for testing
local proc makefakefs {fs} {
set fakefs {}
foreach {type name contents} $fs {
switch -glob -- $type {
f* {
set fakefs($name) [list file $contents]
}
d* {
set fakefs($name) [list dir [makefakefs $contents]]
}
default {
error "Unknown fs type: $type"
}
}
}
return $fakefs
}
# Create a fake filesystem for testing the glob command
set ::FAKEFS [makefakefs {
file abc {This is the contents of abc}
dir def {
file ghi {This file is inside def}
dir jkl
}
dir tmp {
file "open{brace" {}
file "close}brace" {}
file "open\[bracket" {}
file "close\]bracket" {}
}
}]
test glob-1.1 {Simple} {
lsort [glob *]
} {abc def tmp}
test glob-1.2 {Simple} {
lsort [glob a*]
} {abc}
test glob-1.3 {Simple} -returnCodes error -body {
lsort [glob x*]
} -result {no files matched glob patterns}
test glob-1.4 {Simple} -returnCodes error -body {
lsort [glob]
} -result {wrong # args: should be "glob ?options? pattern ?pattern ...?"}
test glob-1.5 {Simple} -returnCodes ok -body {
lsort [glob -nocomplain x*]
} -result {}
test glob-2.1 {Braces} -returnCodes ok -body {
lsort [glob "{a,d}*"]
} -result {abc def}
test glob-2.2 {Files containing braces and brackets} -returnCodes ok -body {
lsort [glob tmp/*]
} -result {tmp/close\]bracket tmp/close\}brace {tmp/open[bracket} tmp/open\{brace}
test glob-2.3 {Glob match files open bracket} -returnCodes ok -body {
lsort [glob {tmp/*\[*}]
} -result [list tmp/open\[bracket]
test glob-2.4 {Glob match files close bracket} -returnCodes ok -body {
lsort [glob {tmp/*\]*}]
} -result [list tmp/close\]bracket]
test glob-2.5 {Glob match files containing braced brackets} -returnCodes ok -body {
lsort [glob {tmp/*{\[,]}*}]
} -result [list tmp/close\]bracket tmp/open\[bracket]
test glob-3.1 {Directory option} -returnCodes ok -body {
lsort [glob -dir tmp *]
} -result [list close\]bracket close\}brace open\[bracket open\{brace]
test glob-3.2 {Directory option} -returnCodes ok -body {
lsort [glob -dir tmp *close*]
} -result [list close\]bracket close\}brace]
testreport

37
debuggers/openocd/jimtcl/tests/infoframe.test Normal file
View File

@ -0,0 +1,37 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim
proc a {n} {
if {$n eq "trace"} {
stacktrace
} else {
info frame $n
}
}
proc b {n} {
a $n
}
proc c {n} {
b $n
}
# --- Don't change line numbers above
test info-frame-1.1 "Current proc" {
c 0
} {a infoframe.test 12}
test info-frame-1.2 "Caller" {
c -1
} {b infoframe.test 16}
test info-frame-1.3 "Caller of Caller" {
c -2
} {c infoframe.test 30}
test stacktrace-1.1 "Full stack trace" {
c trace
} {a infoframe.test 12 b infoframe.test 16 c infoframe.test 34}
testreport

3490
debuggers/openocd/jimtcl/tests/jim.test Normal file
View File

File diff suppressed because it is too large Load Diff

116
debuggers/openocd/jimtcl/tests/linsert.test Normal file
View File

@ -0,0 +1,116 @@
# Commands covered: linsert
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
catch {unset lis}
catch {rename p ""}
test linsert-1.1 {linsert command} {
linsert {1 2 3 4 5} 0 a
} {a 1 2 3 4 5}
test linsert-1.2 {linsert command} {
linsert {1 2 3 4 5} 1 a
} {1 a 2 3 4 5}
test linsert-1.3 {linsert command} {
linsert {1 2 3 4 5} 2 a
} {1 2 a 3 4 5}
test linsert-1.4 {linsert command} {
linsert {1 2 3 4 5} 3 a
} {1 2 3 a 4 5}
test linsert-1.5 {linsert command} {
linsert {1 2 3 4 5} 4 a
} {1 2 3 4 a 5}
test linsert-1.6 {linsert command} {
linsert {1 2 3 4 5} 5 a
} {1 2 3 4 5 a}
test linsert-1.7 {linsert command} {
linsert {1 2 3 4 5} 2 one two \{three \$four
} {1 2 one two \{three {$four} 3 4 5}
test linsert-1.8 {linsert command} {
linsert {\{one \$two \{three \ four \ five} 2 a b c
} {\{one {$two} a b c \{three { four} { five}}
test linsert-1.9 {linsert command} {
linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b}
} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}}
test linsert-1.10 {linsert command} {
linsert {} 2 a b c
} {a b c}
test linsert-1.11 {linsert command} {
linsert {} 2 {}
} {{}}
test linsert-1.12 {linsert command} {
linsert {a b "c c" d e} 3 1
} {a b {c c} 1 d e}
test linsert-1.13 {linsert command} {
linsert { a b c d} 0 1 2
} {1 2 a b c d}
test linsert-1.14 {linsert command} {
linsert {a b c {d e f}} 4 1 2
} {a b c {d e f} 1 2}
test linsert-1.15 {linsert command} {
linsert {a b c \{\ abc} 4 q r
} {a b c \{\ q r abc}
test linsert-1.16 {linsert command} {
linsert {a b c \{ abc} 4 q r
} {a b c \{ q r abc}
test linsert-1.17 {linsert command} {
linsert {a b c} end q r
} {a b c q r}
test linsert-1.18 {linsert command} {
linsert {a} end q r
} {a q r}
test linsert-1.19 {linsert command} {
linsert {} end q r
} {q r}
test linsert-1.20 {linsert command, use of end-int index} {
linsert {a b c d} end-2 e f
} {a b e f c d}
test linsert-2.1 {linsert errors} {
list [catch linsert msg] $msg
} {1 {wrong # args: should be "linsert list index ?element ...?"}}
test linsert-2.2 {linsert errors} {
list [catch {linsert a b} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.3 {linsert errors} {
list [catch {linsert a 12x 2} msg] $msg
} {1 {bad index "12x": must be integer?[+-]integer? or end?[+-]integer?}}
test linsert-2.4 {linsert errors} tcl {
list [catch {linsert \{ 12 2} msg] $msg
} {1 {unmatched open brace in list}}
test linsert-2.5 {syntax (TIP 323)} {
linsert {a b c} 0
} [list a b c]
test linsert-2.6 {syntax (TIP 323)} {
linsert "a\nb\nc" 0
} [list a b c]
test linsert-3.1 {linsert won't modify shared argument objects} {
proc p {} {
linsert "a b c" 1 "x y"
return "a b c"
}
p
} "a b c"
test linsert-3.2 {linsert won't modify shared argument objects} {
catch {unset lis}
set lis [format "a \"%s\" c" "b"]
linsert $lis 0 [string length $lis]
} "7 a b c"
# cleanup
catch {unset lis}
catch {rename p ""}
::tcltest::cleanupTests
return

113
debuggers/openocd/jimtcl/tests/list.test Normal file
View File

@ -0,0 +1,113 @@
# Commands covered: list
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: list.test,v 1.5 2000/04/10 17:19:01 ericm Exp $
source [file dirname [info script]]/testing.tcl
# First, a bunch of individual tests
test list-1.1 {basic tests} {list a b c} {a b c}
test list-1.2 {basic tests} {list {a b} c} {{a b} c}
test list-1.3 {basic tests} {list \{a b c} {\{a b c}
test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}"
test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]"
test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}"
test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}"
test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\}
test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}"
test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}"
test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}"
test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}"
test list-1.13 {basic tests} {list a {{}} b} {a {{}} b}
test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\"
test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\"
test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\"
test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f"
test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r"
test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v"
test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{"
test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd"
test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\
test list-1.23 {basic tests} {list \{} "\\{"
test list-1.24 {basic tests} {list} {}
test list-1.25 {basic tests} {list #} {{#}}
test list-1.26 {basic tests} {list #abc} {{#abc}}
test list-1.27 {basic tests} {list def #abc} {def #abc}
# For the next round of tests create a list and then pick it apart
# with "index" to make sure that we get back exactly what went in.
test list-2.1 {placeholder} {
} {}
set num 1
proc lcheck {a b c} {
global num d
set d [list $a $b $c]
; test list-2.$num {what goes in must come out} {lindex $d 0} $a
set num [expr $num+1]
; test list-2.$num {what goes in must come out} {lindex $d 1} $b
set num [expr $num+1]
; test list-2.$num {what goes in must come out} {lindex $d 2} $c
set num [expr $num+1]
}
lcheck a b c
lcheck "a b" c\td e\nf
lcheck {{a b}} {} { }
lcheck \$ \$ab ab\$
lcheck \; \;ab ab\;
lcheck \[ \[ab ab\[
lcheck \\ \\ab ab\\
lcheck {"} {"ab} {ab"}
lcheck {a b} { ab} {ab }
lcheck a{ a{b \{ab
lcheck a} a}b }ab
lcheck a\\} {a \}b} {a \{c}
lcheck xyz \\ 1\\\n2
lcheck "{ab}\\" "{ab}xy" abc
concat {}
# Check that tclListObj.c's SetListFromAny handles possible overlarge
# string rep lengths in the source object.
proc slowsort list {
set result {}
set last [expr [llength $list] - 1]
while {$last > 0} {
set minIndex [expr [llength $list] - 1]
set min [lindex $list $last]
set i [expr $minIndex-1]
while {$i >= 0} {
if {[string compare [lindex $list $i] $min] < 0} {
set minIndex $i
set min [lindex $list $i]
}
set i [expr $i-1]
}
set result [concat $result [list $min]]
if {$minIndex == 0} {
set list [lrange $list 1 end]
} else {
set list [concat [lrange $list 0 [expr $minIndex-1]] \
[lrange $list [expr $minIndex+1] end]]
}
set last [expr $last-1]
}
return [concat $result $list]
}
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
testreport

152
debuggers/openocd/jimtcl/tests/loop.test Normal file
View File

@ -0,0 +1,152 @@
source [file dirname [info script]]/testing.tcl
# Check "loop" and its use of continue and break.
needs cmd loop
catch {unset a i}
test loop-1.1 {loop tests} {
set a {}
loop i 1 6 {
set a [concat $a $i]
}
set a
} {1 2 3 4 5}
test loop-1.2 {loop tests} {
set a {}
loop i 1 6 {
if $i==4 continue
set a [concat $a $i]
}
set a
} {1 2 3 5}
test loop-1.3 {loop tests} {
set a {}
loop i 1 6 {
if $i==4 break
set a [concat $a $i]
}
set a
} {1 2 3}
test loop-1.5 {loop errors} {
catch {loop 1 2 3} msg
} {1}
test loop-1.6 {loop errors} {
catch {loop 1 2 3 4 5} msg
} {1}
test loop-1.7 {loop tests} {
set a {xyz}
loop i 1 6 {
}
set a
} xyz
test loop-1.8 {error in loop} {
set rc [catch {
set a {}
loop i 1 6 {
lappend a $i
if {$i == 3} {
error "stop"
}
}
}]
list $a $rc
} {{1 2 3} 1}
test loop-1.9 {loop incr} {
set a {}
loop i 0 6 2 {
lappend a $i
}
set a
} {0 2 4}
test loop-1.10 {no exec infinite loop} {
set a {}
loop i 0 6 -1 {
lappend a $i
break
}
set a
} {}
test loop-2.1 {loop shimmering tests} {
loop i 1 6 {
}
set i
} 6
test loop-2.2 {loop shimmering tests} {
# Setting the variable inside the loop doesn't
# affect the loop or the final variable value
loop i 1 6 {
set i blah
}
set i
} 6
test loop-2.3 {loop shimmering tests} {
set a {}
loop i 1 6 {
lappend a $i
set i blah
lappend a $i
}
set a
} {1 blah 2 blah 3 blah 4 blah 5 blah}
test loop-2.4 {loop shimmering tests} {
set i xyz
loop i 1 6 {
}
set i
} 6
test loop-2.5 {loop shimmering tests} {
# Ensure that the string rep of $i is updated
set i {1 3}
loop i(1) 1 6 {
}
set i
} {1 6}
test loop-2.6 {modify loop var} {
unset -nocomplain i
catch {
loop i(1) 1 6 {
# this makes it impossible to set the loop var
set i blah
}
}
} 1
test loop-2.7 {unset loop var} {
unset -nocomplain i
loop i 1 6 {
# var will simply get recreated on each loop
unset i
}
set i
} 6
test loop-2.8 {modify loop var} {
unset -nocomplain i
set a {}
loop i 1 6 {
lappend a $i
incr i
}
set a
} {1 2 3 4 5}
testreport
break
testreport

85
debuggers/openocd/jimtcl/tests/lrange.test Normal file
View File

@ -0,0 +1,85 @@
# Commands covered: lrange
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
test lrange-1.3 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 3 end
} {l15 d}
test lrange-1.4 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000
} {d}
test lrange-1.5 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 4 3
} {}
test lrange-1.6 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 10 11
} {}
test lrange-1.7 {range of list elements} {
lrange {a b c d e} -1 2
} {a b c}
test lrange-1.8 {range of list elements} {
lrange {a b c d e} -2 -1
} {}
test lrange-1.9 {range of list elements} {
lrange {a b c d e} -2 end
} {a b c d e}
test lrange-1.10 {range of list elements} {
lrange "a b\{c d" 1 2
} "b\\{c d"
test lrange-1.11 {range of list elements} {
lrange "a b c d" end end
} d
test lrange-1.12 {range of list elements} {
lrange "a b c d" end 100000
} d
test lrange-1.13 {range of list elements} {
lrange "a b c d" end 3
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.15 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
test lrange-1.16 {list element quoting} {
lrange {[append a .b]} 0 end
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} tcl {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
test lrange-2.6 {error conditions} tcl {
list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
} {1 {unmatched open brace in list}}
# cleanup
::tcltest::cleanupTests
return

133
debuggers/openocd/jimtcl/tests/lreplace.test Normal file
View File

@ -0,0 +1,133 @@
# Commands covered: lreplace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
test lreplace-1.2 {lreplace command} {
lreplace {1 2 3 4 5} 1 1 a
} {1 a 3 4 5}
test lreplace-1.3 {lreplace command} {
lreplace {1 2 3 4 5} 2 2 a
} {1 2 a 4 5}
test lreplace-1.4 {lreplace command} {
lreplace {1 2 3 4 5} 3 3 a
} {1 2 3 a 5}
test lreplace-1.5 {lreplace command} {
lreplace {1 2 3 4 5} 4 4 a
} {1 2 3 4 a}
test lreplace-1.6 {lreplace command} {
lreplace {1 2 3 4 5} 4 5 a
} {1 2 3 4 a}
test lreplace-1.7 {lreplace command} {
lreplace {1 2 3 4 5} -1 -1 a
} {a 1 2 3 4 5}
test lreplace-1.8 {lreplace command} {
lreplace {1 2 3 4 5} 2 end a b c d
} {1 2 a b c d}
test lreplace-1.9 {lreplace command} {
lreplace {1 2 3 4 5} 0 3
} {5}
test lreplace-1.10 {lreplace command} {
lreplace {1 2 3 4 5} 0 4
} {}
test lreplace-1.11 {lreplace command} {
lreplace {1 2 3 4 5} 0 1
} {3 4 5}
test lreplace-1.12 {lreplace command} {
lreplace {1 2 3 4 5} 2 3
} {1 2 5}
test lreplace-1.13 {lreplace command} {
lreplace {1 2 3 4 5} 3 end
} {1 2 3}
test lreplace-1.14 {lreplace command} {
lreplace {1 2 3 4 5} -1 4 a b c
} {a b c}
test lreplace-1.15 {lreplace command} {
lreplace {a b "c c" d e f} 3 3
} {a b {c c} e f}
test lreplace-1.16 {lreplace command} {
lreplace { 1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
test lreplace-1.17 {lreplace command} {
lreplace {1 2 3 4 "5 6"} 4 4 a
} {1 2 3 4 a}
test lreplace-1.18 {lreplace command} {
lreplace {1 2 3 4 {5 6}} 4 4 a
} {1 2 3 4 a}
test lreplace-1.19 {lreplace command} {
lreplace {1 2 3 4} 2 end x y z
} {1 2 x y z}
test lreplace-1.20 {lreplace command} {
lreplace {1 2 3 4} end end a
} {1 2 3 a}
test lreplace-1.21 {lreplace command} {
lreplace {1 2 3 4} end 3 a
} {1 2 3 a}
test lreplace-1.22 {lreplace command} {
lreplace {1 2 3 4} end end
} {1 2 3}
test lreplace-1.23 {lreplace command} {
lreplace {1 2 3 4} 2 -1 xy
} {1 2 xy 3 4}
test lreplace-1.24 {lreplace command} {
lreplace {1 2 3 4} end -1 z
} {1 2 3 z 4}
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
test lreplace-1.26 {lreplace command} {
catch {unset foo}
set foo {a b}
list [set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
test lreplace-2.1 {lreplace errors} {
list [catch lreplace msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.2 {lreplace errors} {
list [catch {lreplace a b} msg] $msg
} {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.3 {lreplace errors} {
list [catch {lreplace x a 10} msg] $msg
} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.4 {lreplace errors} {
list [catch {lreplace x 10 x} msg] $msg
} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} {
list [catch {lreplace x 10 1x} msg] $msg
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} {
list [catch {lreplace x 3 2} msg] $msg
} {1 {list doesn't contain element 3}}
test lreplace-2.7 {lreplace errors} {
list [catch {lreplace x 1 1} msg] $msg
} {1 {list doesn't contain element 1}}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
lreplace "a b c" 1 1 "x y"
return "a b c"
}
p
} "a b c"
# cleanup
catch {unset foo}
::tcltest::cleanupTests
return

182
debuggers/openocd/jimtcl/tests/lsearch.test Normal file
View File

@ -0,0 +1,182 @@
# Commands covered: lsearch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lsearch.test,v 1.5 2000/04/10 17:19:01 ericm Exp $
source [file dirname [info script]]/testing.tcl
catch {package require regexp}
testConstraint regexp [expr {[info commands regexp] ne {}}]
set x {abcd bbcd 123 234 345}
test lsearch-1.1 {lsearch command} {
lsearch $x 123
} 2
test lsearch-1.2 {lsearch command} {
lsearch $x 3456
} -1
test lsearch-1.3 {lsearch command} {
lsearch -glob $x *5
} 4
test lsearch-1.4 {lsearch command} {
lsearch -glob $x *bc*
} 0
test lsearch-2.1 {search modes} {
lsearch -exact {xyz bbcc *bc*} *bc*
} 2
test lsearch-2.2 {search modes} {
lsearch -exact {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.3 {search modes} {
lsearch -exact {foo bar cat} ba
} -1
test lsearch-2.4 {search modes} {
lsearch -exact {foo bar cat} bart
} -1
test lsearch-2.5 {search modes} {
lsearch -exact {foo bar cat} bar
} 1
test lsearch-2.6 {search modes} regexp {
list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg]
} {1}
test lsearch-2.7 {search modes} regexp {
lsearch -regexp {b.x ^bc xy bcx} ^bc
} 3
test lsearch-2.8 {search modes} {
lsearch -glob {xyz bbcc *bc*} *bc*
} 1
test lsearch-2.9 {search modes} {
lsearch -glob {b.x ^bc xy bcx} ^bc
} 1
test lsearch-2.10 {search modes} {
list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg]
} {1}
test lsearch-2.7 {search modes, -nocase} regexp {
lsearch -nocase -regexp {b.x ^bc xy bcx} ^BC
} 3
test lsearch-2.8 {search modes, -nocase} {
lsearch -nocase -exact {b.x ^bc xy bcx} ^BC
} 1
test lsearch-2.9 {search modes, -nocase} {
lsearch -nocase -glob {b.x ^bc xy bcx} B*
} 0
test lsearch-3.1 {lsearch errors} {
list [catch lsearch msg]
} {1}
test lsearch-3.2 {lsearch errors} {
list [catch {lsearch a} msg]
} {1}
test lsearch-3.3 {lsearch errors} {
list [catch {lsearch a b c} msg]
} {1}
test lsearch-3.4 {lsearch errors} {
list [catch {lsearch a b c d} msg]
} {1}
test lsearch-4.1 {binary data} {
lsearch -exact [list foo one\000two bar] bar
} 2
test lsearch-4.2 {binary data} {
set x one
append x \x00
append x two
lsearch -exact [list foo one\000two bar] $x
} 1
test lsearch-5.1 {lsearch -all} {
lsearch -glob -all {a1 a2 b1 b2 a3 b3} a*
} {0 1 4}
test lsearch-5.2 {lsearch -all no match} {
lsearch -glob -all {a1 a2 b1 b2 a3 b3} B*
} {}
test lsearch-5.3 {lsearch -all -nocase} {
lsearch -glob -all -nocase {a1 a2 b1 b2 a3 b3} B*
} {2 3 5}
test lsearch-5.4 {lsearch -all -inline} {
lsearch -glob -all -inline -nocase {a1 a2 b1 b2 a3 b3} A*
} {a1 a2 a3}
test lsearch-5.5 {lsearch -inline} {
lsearch -glob -inline {a1 a2 b1 b2 a3 b3} b*
} {b1}
test lsearch-5.6 {lsearch -not -all} {
lsearch -not -glob -all {a1 a2 b1 b2 a3 b3} a*
} {2 3 5}
test lsearch-5.7 {lsearch -not -all no match} {
lsearch -not -glob -all {a1 a2 b1 b2 a3 b3} B*
} {0 1 2 3 4 5}
test lsearch-5.8 {lsearch -not -all -nocase} {
lsearch -not -glob -all -nocase {a1 a2 b1 b2 a3 b3} B*
} {0 1 4}
test lsearch-5.9 {lsearch -not -all -inline} {
lsearch -not -glob -all -inline -nocase {a1 a2 b1 b2 a3 b3} A*
} {b1 b2 b3}
test lsearch-5.10 {lsearch -not -inline} {
lsearch -not -glob -inline {a1 a2 b1 b2 a3 b3} b*
} {a1}
test lsearch-5.11 {lsearch -inline, no match} {
lsearch -glob -inline {a1 a2 b1 b2 a3 b3} C*
} {}
test lsearch-6.1 {lsearch -bool, found} jim {
lsearch -bool {a1 a2 b1 b2 a3 b3} b1
} {1}
test lsearch-6.2 {lsearch -bool, not found} jim {
lsearch -bool {a1 a2 b1 b2 a3 b3} c1
} {0}
test lsearch-6.3 {lsearch -not -bool, found} jim {
lsearch -not -bool {a1 a2 b1 b2 a3 b3} b1
} {0}
test lsearch-6.4 {lsearch -not -bool, not found} jim {
lsearch -not -bool {a1 a2 b1 b2 a3 b3} c1
} {1}
test lsearch-6.5 {lsearch -bool -all} jim {
lsearch -bool -glob -all {a1 a2 b1 b2 a3 b3} a*
} {1 1 0 0 1 0}
test lsearch-6.6 {lsearch -bool -all no match} jim {
lsearch -bool -glob -all {a1 a2 b1 b2 a3 b3} B*
} {0 0 0 0 0 0}
test lsearch-6.7 {lsearch -bool -all -nocase} jim {
lsearch -bool -glob -all -nocase {a1 a2 b1 b2 a3 b3} B*
} {0 0 1 1 0 1}
test lsearch-6.8 {lsearch -not -bool -all} jim {
lsearch -not -bool -glob -all {a1 a2 b1 b2 a3 b3} a*
} {0 0 1 1 0 1}
test lsearch-6.9 {lsearch -not -bool -all no match} jim {
lsearch -not -bool -glob -all {a1 a2 b1 b2 a3 b3} B*
} {1 1 1 1 1 1}
test lsearch-6.10 {lsearch -not -bool -all -nocase} jim {
lsearch -not -bool -glob -all -nocase {a1 a2 b1 b2 a3 b3} B*
} {1 1 0 0 1 0}
testreport

201
debuggers/openocd/jimtcl/tests/lsort.test Normal file
View File

@ -0,0 +1,201 @@
# This file contains a collection of tests for the procedures in the
# file tclCmdIL.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lsort.test,v 1.12.2.2 2001/10/08 15:50:24 dkf Exp $
source [file dirname [info script]]/testing.tcl
test lsort-1.1 {Tcl_LsortObjCmd procedure} jim {
list [catch {lsort} msg] $msg
} {1 {wrong # args: should be "lsort ?options? list"}}
test lsort-1.2 {Tcl_LsortObjCmd procedure} jim {
list [catch {lsort -foo {1 3 2 5}} msg] $msg
} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -increasing, -index, -integer, or -nocase}}
test lsort-1.3 {Tcl_LsortObjCmd procedure, default options} {
lsort {d e c b a \{ d35 d300}
} {a b c d d300 d35 e \{}
test lsort-1.4 {Tcl_LsortObjCmd procedure, -ascii option} {
lsort -integer -ascii {d e c b a d35 d300}
} {a b c d d300 d35 e}
test lsort-1.5 {Tcl_LsortObjCmd procedure, -command option} {
list [catch {lsort -command {1 3 2 5}} msg] $msg
} {1 {"-command" option must be followed by comparison command}}
test lsort-1.6 {Tcl_LsortObjCmd procedure, -command option} {
proc cmp {a b} {
set rc [expr {[string match x* $b] - [string match x* $a]}]
if {$rc == 0} {
set rc [string compare $a $b]
}
return $rc
}
lsort -command cmp {x1 abc x2 def x3 x4}
} {x1 x2 x3 x4 abc def}
test lsort-1.7 {Tcl_LsortObjCmd procedure, -decreasing option} {
lsort -decreasing {d e c b a d35 d300}
} {e d35 d300 d c b a}
test lsort-1.10 {Tcl_LsortObjCmd procedure, -increasing option} {
lsort -decreasing -increasing {d e c b a d35 d300}
} {a b c d d300 d35 e}
test lsort-1.11 {Tcl_LsortObjCmd procedure, -index option} {
list [catch {lsort -index {1 3 2 5}} msg] $msg
} {1 {"-index" option must be followed by list index}}
test lsort-1.12 {Tcl_LsortObjCmd procedure, -index option} {
list [catch {lsort -index foo {1 3 2 5}} msg] $msg
} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}}
test lsort-1.13 {Tcl_LsortObjCmd procedure, -index option} {
lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1}
} {1 {2 25} {3 16 42} {10 20 50 100}}
test lsort-1.14 {Tcl_LsortObjCmd procedure, -index option} {
lsort -index 1 -integer {{1 25 100} {3 16 42} {10 20 50}}
} {{3 16 42} {10 20 50} {1 25 100}}
test lsort-1.15 {Tcl_LsortObjCmd procedure, -integer option} {
lsort -integer {24 6 300 18}
} {6 18 24 300}
test lsort-1.16 {Tcl_LsortObjCmd procedure, -integer option} {
list [catch {lsort -integer {1 3 2.4}} msg] $msg
} {1 {expected integer but got "2.4"}}
test lsort-1.19 {Tcl_LsortObjCmd procedure, empty list} {
lsort {}
} {}
test lsort-1.24 {Tcl_LsortObjCmd procedure, order of -index and -command} {
catch {rename 1 ""}
proc testcmp {a b} {return [string compare $a $b]}
set l [list [list a b] [list c d]]
set result [list [catch {lsort -command testcmp -index 1 $l} msg] $msg]
rename testcmp ""
set result
} [list 0 [list [list a b] [list c d]]]
test lsort-1.25 {Tcl_LsortObjCmd procedure, order of -index and -command} {
catch {rename 1 ""}
proc testcmp {a b} {return [string compare $a $b]}
set l [list [list a b] [list c d]]
set result [list [catch {lsort -index 1 -command testcmp $l} msg] $msg]
rename testcmp ""
set result
} [list 0 [list [list a b] [list c d]]]
# Note that the required order only exists in the end-1'th element;
# indexing using the end element or any fixed offset from the start
# will not work...
test lsort-1.26 {Tcl_LsortObjCmd procedure, offset indexing from end} {
lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
} {{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}}
# Can't think of any good tests for the MergeSort and MergeLists
# procedures, except a bunch of random lists to sort.
test lsort-2.1 {MergeSort and MergeLists procedures} {
set result {}
set r 1435753299
proc rand {} {
global r
set r [expr {(16807 * $r) % (0x7fffffff)}]
}
for {set i 0} {$i < 150} {incr i} {
set x {}
for {set j 0} {$j < $i} {incr j} {
lappend x [expr {[rand] & 0xfff}]
}
set y [lsort -integer $x]
set old -1
foreach el $y {
if {$el < $old} {
append result "list {$x} sorted to {$y}, element $el out of order\n"
break
}
set old $el
}
}
set result
} {}
test lsort-3.1 {SortCompare procedure, skip comparisons after error} {
set x 0
proc cmp {a b} {
global x
incr x
error "error #$x"
}
list [catch {lsort -integer -command cmp {48 6 28 190 16 2 3 6 1}} msg] \
$msg $x
} {1 {error #1} 1}
test lsort-3.3 {SortCompare procedure, -index option} jim {
list [catch {lsort -integer -index 2 {{20 10} {15 30 40}}} msg] $msg
} {1 {list index out of range}}
test lsort-3.5 {SortCompare procedure, -index option} jim {
list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg
} {1 {list index out of range}}
test lsort-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
test lsort-3.7 {SortCompare procedure, -ascii option} {
lsort -ascii {d e c b a d35 d300 100 20}
} {100 20 a b c d d300 d35 e}
test lsort-3.9 {SortCompare procedure, -integer option} {
list [catch {lsort -integer {x 3}} msg] $msg
} {1 {expected integer but got "x"}}
test lsort-3.10 {SortCompare procedure, -integer option} {
list [catch {lsort -integer {3 q}} msg] $msg
} {1 {expected integer but got "q"}}
test lsort-3.11 {SortCompare procedure, -integer option} {
lsort -integer {35 21 0x20 30 023 100 8}
} {8 21 023 30 0x20 35 100}
test lsort-3.15 {SortCompare procedure, -command option} {
proc cmp {a b} {
error "comparison error"
}
list [catch {lsort -command cmp {48 6}} msg] $msg
} {1 {comparison error}}
test lsort-3.16 {SortCompare procedure, -command option, long command} {
proc cmp {dummy a b} {
string compare $a $b
}
lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}}
} {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}}
test lsort-3.17 {SortCompare procedure, -command option, non-integer result} jim {
proc cmp {a b} {
return foow
}
list [catch {lsort -command cmp {48 6}} msg] $msg
} {1 {expected integer but got "foow"}}
test lsort-3.18 {SortCompare procedure, -command option} {
proc cmp {a b} {
expr {$b - $a}
}
lsort -command cmp {48 6 18 22 21 35 36}
} {48 36 35 22 21 18 6}
test lsort-3.19 {SortCompare procedure, -decreasing option} {
lsort -decreasing -integer {35 21 0x20 30 023 100 8}
} {100 35 0x20 30 023 21 8}
test lsort-4.26 {DefaultCompare procedure, signed characters} utf8 {
set l [lsort [list "abc\u80" "abc"]]
set viewlist {}
foreach s $l {
set viewelem ""
set len [string length $s]
for {set i 0} {$i < $len} {incr i} {
set c [string index $s $i]
scan $c %c d
if {$d > 0 && $d < 128} {
append viewelem $c
} else {
append viewelem "\\[format %03o [expr {$d & 0xff}]]"
}
}
lappend viewlist $viewelem
}
set viewlist
} [list "abc" "abc\\200"]
test lsort-5.1 "Sort case insensitive" {
lsort -nocase {ba aB aa ce}
} {aa aB ba ce}
testreport

32
debuggers/openocd/jimtcl/tests/lsortcmd.test Normal file
View File

@ -0,0 +1,32 @@
source [file dirname [info script]]/testing.tcl
set list {b d a c z}
proc sorter {a v1 v2} {
set ::arg $a
return [string compare $v1 $v2]
}
proc test_lsort_cmd {test cmd list exp} {
lsort -command $cmd $list
if {$::arg != $exp} {
error "$test: Failed"
}
}
test lsortcmd-1.1 "Sort with one arg" {
lsort -command "sorter arg1" $list
set arg
} {arg1}
test lsortcmd-1.2 "Sort with one arg containg spaces" {
lsort -command {sorter "arg with space"} $list
set arg
} {arg with space}
test lsortcmd-1.3 "Sort with arg as list containg spaces" {
lsort -command [list sorter [list arg with list "last with spaces"]] $list
set arg
} {arg with list {last with spaces}}
testreport

563
debuggers/openocd/jimtcl/tests/misc.test Normal file
View File

@ -0,0 +1,563 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd gets tclcompat
needs cmd array
catch {unset a b}
test regr-1.1 "Double dereference arrays" {
array set a {one ONE two TWO three THREE}
array set b {ONE 1 TWO 2 THREE 3}
set chan two
set b($a($chan))
} {2}
# Will assert on exit if the bug exists
test regr-1.2 "Reference count shared literals" {
proc a {} {
while {1} {break}
}
a
rename a ""
return 1
} {1}
test regr-1.3 "Invalid for expression" jim {
# Crashes with invalid expression
catch {
for {set i 0} {$i < n} {incr i} {
set a(b) $i
set a(c) $i
break
}
}
} 1
test regr-1.4 "format double percent" {
format (%d%%) 12
} {(12%)}
test regr-1.5 "lassign with empty list" {
unset -nocomplain a b c
lassign {} a b c
info exists c
} {1}
test io-1.1 "Read last line with no newline" {
set lines 0
set f [open $testdir/testio.in]
while {[gets $f buf] >= 0} {
incr lines
}
close $f
list $lines
} {2}
set g1 1
set g2 2
array set g3 {4 5 6 7}
proc test_unset {} {
test unset-1.1 "Simple var" {
set g4 4
list [catch {unset g4; info exists g4} msg] $msg
} {0 0}
test unset-1.2 "Simple var" {
list [catch {unset g4; info exists g4} msg] $msg
} {1 {can't unset "g4": no such variable}}
test unset-1.3 "Simple var" {
list [catch {unset g2; info exists g2} msg] $msg
} {1 {can't unset "g2": no such variable}}
test unset-1.4 "Global via global" {
global g1
list [catch {unset g1; info exists g1} msg] $msg
} {0 0}
test unset-1.5 "Global error" {
list [catch {unset ::g2; info exists ::g2} msg] $msg
} {0 0}
test unset-1.6 "Global array" {
list [catch {unset ::g3; info exists ::g3} msg] $msg
} {0 0}
test unset-1.7 "Simple var -nocomplain" {
list [catch {unset -nocomplain g2; info exists g2} msg] $msg
} {0 0}
test unset-1.8 "Simple var --" {
list [catch {unset -- g2; info exists g2} msg] $msg
} {1 {can't unset "g2": no such variable}}
test unset-1.9 "Simple var -nocomplain --" {
set g2 1
list [catch {unset -nocomplain -- g2; info exists g2} msg] $msg
} {0 0}
test unset-1.10 "Var named -nocomplain with --" {
set -nocomplain 1
list [catch {unset -- -nocomplain; info exists -nocomplain} msg] $msg
} {0 0}
test unset-1.11 "Unset no args" {
list [catch {unset} msg] $msg
} {0 {}}
}
test_unset
test lrepeat-1.1 "Basic tests" {
lrepeat 1 a
} {a}
test lrepeat-1.2 "Basic tests" {
lrepeat 1 a b
} {a b}
test lrepeat-1.3 "Basic tests" {
lrepeat 2 a b
} {a b a b}
test lrepeat-1.4 "Basic tests" {
lrepeat 2 a
} {a a}
test lrepeat-1.5 "Errors" {
catch {lrepeat}
} {1}
test lrepeat-1.6 "Errors" {
lrepeat 1
} {}
test lrepeat-1.7 "Errors" {
lrepeat 0 a b
} {}
test lrepeat-1.8 "Errors" {
catch {lrepeat -10 a}
} {1}
test lindex-1.1 "Integer" {
lindex {a b c} 0
} a
test lindex-1.2 "Integer" {
lindex {a b c} 2
} c
test lindex-1.3 "Integer" {
lindex {a b c} -1
} {}
test lindex-1.4 "Integer" {
lindex {a b c} 4
} {}
test lindex-1.5 "end" {
lindex {a b c} end
} c
test lindex-1.6 "end" {
lindex {a b c} end-1
} b
test lindex-1.7 "end" {
lindex {a b c} end-4
} {}
test lindex-1.8 "end + " {
lindex {a b c} end+1
} {}
test lindex-1.9 "end + " {
lindex {a b c} end+-1
} b
test lindex-1.10 "end - errors" {
catch {lindex {a b c} end-}
} 1
test lindex-1.11 "end - errors" {
catch {lindex {a b c} end-blah}
} 1
test lindex-1.12 "int+int, int-int" {
lindex {a b c} 0+4
} {}
test lindex-1.13 "int+int, int-int" {
lindex {a b c} 3-1
} c
test lindex-1.14 "int+int, int-int" {
lindex {a b c} 1--1
} c
test lindex-1.15 "int+int, int-int" {
set l {a b c}
lindex $l [lsearch $l b]-1
} a
test lindex-1.16 "int+int, int-int" {
lindex {a b c} 0+1
} b
test lindex-1.17 "int+int - errors" {
catch {lindex {a b c} 5-blah}
} 1
test lindex-1.18 "int+int - errors" {
catch {lindex {a b c} blah-2}
} 1
test lindex-1.19 "int+int - errors" {
catch {lindex {a b c} 5+blah}
} 1
test lindex-1.20 "unary plus" {
lindex {a b c} +2
} c
test incr-1.1 "incr unset" {
unset -nocomplain a
incr a
set a
} 1
test incr-1.2 "incr, incr unset" {
incr a
} 2
test incr-1.3 "incr unset array element" {
unset -nocomplain a
incr a(2)
set a(2)
} 1
test incr-1.4 "incr array element - shimmering" {
set b "$a(2)-test"
incr a(2)
} 2
test catch-1.1 "catch ok" {
list [catch {set abc 2} result] $result
} {0 2}
test catch-1.2 "catch error" {
list [catch {error 3} result] $result
} {1 3}
test catch-1.3 "catch break" {
list [catch {break} result] $result
} {3 {}}
test catch-1.4 "catch -nobreak" {
set result {}
foreach x {a b c} {
lappend result $x
# This acts just like break since it won't be caught by catch
catch -nobreak {break} tmp
}
set result
} {a}
test catch-1.5 "catch -no3" {
set result {}
foreach x {a b c} {
lappend result $x
# Same as above, but specify as an integer
catch -no3 {break} tmp
}
set result
} {a}
test catch-1.6 "catch break" {
set result {}
foreach x {a b c} {
lappend result $x
# This does nothing since the break is caught
catch {break} tmp
}
set result
} {a b c}
test catch-1.7 "catch exit" {
# Normally exit would not be caught
dict get [info returncodes] [catch -exit {exit 5} result]
} {exit}
test catch-1.8 "catch error has -errorinfo" {
set rc [catch {set undefined} msg opts]
list $rc [info exists opts(-errorinfo)]
} {1 1}
test catch-1.9 "catch no error has no -errorinfo" {
set rc [catch {set x 1} msg opts]
list $rc [info exists opts(-errorinfo)]
} {0 0}
test return-1.1 "return can rethrow an error" {
proc a {} { error "from a" }
proc b {} { catch {a} msg opts; return {*}$opts $msg }
set rc [catch {b} msg opts]
list $rc $msg [llength $opts(-errorinfo)]
} {1 {from a} 6}
test return-1.2 "error can rethrow an error" {
proc a {} { error "from a" }
proc b {} { catch {a} msg; error $msg [info stacktrace] }
set rc [catch {b} msg opts]
list $rc $msg [llength $opts(-errorinfo)]
} {1 {from a} 9}
test return-1.3 "return can rethrow no error" {
proc a {} { return "from a" }
proc b {} { catch {a} msg opts; return {*}$opts $msg }
set rc [catch {b} msg opts]
#list $rc $msg [llength $opts(-errorinfo)]
list $rc $msg [info exists opts(-errorinfo)]
} {0 {from a} 0}
test stringreverse-1.1 "Containing nulls" {
string reverse abc\0def
} "fed\0cba"
test split-1.1 "Split with leading null" {
split "\0abc\0def\0" \0
} {{} abc def {}}
test parsevar-1.1 "Variables should include double colons" {
set ::a::b 2
set x $::a::b
unset ::a::b
set x
} 2
test sharing-1.1 "Problems with ref sharing in arrays: lappend" {
set a {a 1 c 2}
set b $a
lappend b(c) 3
set a(c)
} 2
test sharing-1.2 "Problems with ref sharing in arrays: append" {
set a {a 1 c 2}
set b $a
append b(c) 3
set a(c)
} 2
test sharing-1.3 "Problems with ref sharing in arrays: incr" {
set a {a 1 c 2}
set b $a
incr b(c)
set a(c)
} 2
test sharing-1.4 "Problems with ref sharing in arrays: lset" {
set a {a 1 c {2 3}}
set b $a
lset b(c) 1 x
set a(c)
} {2 3}
test jimexpr-1.1 "integer ** operator" {
expr {2 ** 3}
} 8
test jimexpr-1.2 "integer ** operator" {
expr {0 ** 3}
} 0
test jimexpr-1.3 "integer ** operator" {
expr {2 ** 0}
} 1
test jimexpr-1.4 "integer ** operator" {
expr {-2 ** 1}
} -2
test jimexpr-1.5 "integer ** operator" {
expr {3 ** -2}
} 0
test jimexpr-1.6 "+ command" {
+ 1
} 1
test jimexpr-1.7 "+ command" {
+ 2 3.5
} 5.5
test jimexpr-1.8 "+ command" {
+ 2 3 4 -6
} 3
test jimexpr-1.9 "* command" {
* 4
} 4
test jimexpr-1.10 "* command" {
* 4 2
} 8
test jimexpr-1.11 "* command" {
* 4 2 -0.5
} -4.0
test jimexpr-1.12 "/ command" {
/ 2
} 0.5
test jimexpr-1.12 "/ command" {
/ 0.5
} 2.0
test jimexpr-1.13 "/ command" {
/ 12 3
} 4
test jimexpr-1.14 "/ command" {
/ 12 3 2.0
} 2.0
test jimexpr-1.15 "- command" {
- 6
} -6
test jimexpr-1.15 "- command" {
- 6.5
} -6.5
test jimexpr-1.16 "- command" {
- 6 3
} 3
test jimexpr-1.17 "- command" {
- 6 3 1.5
} 1.5
test jimexpr-1.17 "- command" {
- 6.5 3
} 3.5
test jimexpr-2.1 "errors in math commands" {
list [catch /] [catch {/ x}] [catch -] [catch {- blah blah}] [catch {- 2.0 blah}] [catch {+ x y}] [catch {* x}]
} {1 1 1 1 1 1 1}
test jimexpr-2.2 "not var optimisation" {
set x [expr 1]
set y [expr 0]
set z [expr 2.0]
list [expr {!$x}] [expr {!$y}] [expr {!$z}]
} {0 1 0}
test jimexpr-2.3 "expr access unset var" {
unset -nocomplain a
catch {expr {3 * $a}}
} 1
test jimexpr-2.4 "expr double as bool" {
set x 2
if {1.0} {
set x 3
}
} 3
# May be supported if support compiled in
test jimexpr-2.5 "double ** operator" {
catch {expr {2.0 ** 3}} result
expr {$result in {unsupported 8.0}}
} 1
# This one is for test coverage of an unusual case
test jimobj-1.1 "duplicate obj with no dupIntRepProc" {
proc "x x" {} { return 2 }
set a "x x"
# force it to be a command object
set b [$a]
# A second reference
set c $a
# Now force it to be duplicated
lset a 1 x
# force the duplicate object it to be a command object again
set b [$a]
# And get the string rep
set x "y $a"
} "y x x"
test jimobj-1.2 "cooerced double to int" {
set x 3
# cooerce to a double
expr {4.5 + $x}
# Now get the int rep
incr x
} 4
test jimobj-1.3 "cooerced double to double" {
set x 3
# cooerce to a double
expr {4.5 + $x}
# Now use as a double
expr {1.5 + $x}
} 4.5
test jimobj-1.4 "incr dict sugar" {
unset -nocomplain a
set a(3) 3
incr a(3)
list $a(3) $a
} {4 {3 4}}
test jim-badvar-1.1 "invalid variable name" {
set x b\0c
catch {set $x 5}
} 1
test jim-badvar-1.2 "incr invalid variable name" {
set x b\0c
catch {incr $x}
} 1
test lset-1.1 "lset with bad var" {
catch {lset badvar 1 x}
} 1
test dict-1.1 "dict to string" {
set a [dict create abc \\ def \"]
set x x$a
} "xabc \\\\ def {\"}"
test channels-1.1 {info channels} {
lsort [info channels]
} {stderr stdin stdout}
test lmap-1.1 {lmap} {
lmap p {1 2 3} {incr p}
} {2 3 4}
test exprerr-1.1 {Error message with bad expr} {
catch {expr {5 ||}} msg
set msg
} {Expression has bad operands to ||}
test eval-list-1.1 {Lost string rep with list} {
set x {set y 1; incr y}
# Convert to list rep internally
lindex $x 4
# But make sure we don't lost the original string rep
list [catch $x] $y
} {0 2}
test info-statics-1.1 {info statics commands} {
set x 1
proc a {} {x {y 2}} {}
info statics a
} {x 1 y 2}
testreport

493
debuggers/openocd/jimtcl/tests/namespace.test Normal file
View File

@ -0,0 +1,493 @@
source [file dirname [info script]]/testing.tcl
needs cmd namespace
test namespace-1.1 {usage for "namespace" command} -body {
namespace
} -returnCodes error -match glob -result {wrong # args: should be *}
test namespace-1.2 {global namespace's name is "::" or {}} {
list [namespace current] [namespace eval {} {namespace current}] [namespace eval :: {namespace current}]
} {:: :: ::}
test namespace-1.3 {usage for "namespace eval"} -body {
namespace eval
} -returnCodes error -match glob -result {wrong # args: should be "namespace eval *"}
test namespace-1.5 {access a new namespace} {
namespace eval ns1 { namespace current }
} {::ns1}
test namespace-1.7 {usage for "namespace eval"} -body {
namespace eval ns1
} -returnCodes error -match glob -result {wrong # args: should be "namespace eval *"}
test namespace-1.8 {command "namespace eval" concatenates args} {
namespace eval ns1 namespace current
} {::ns1}
test namespace-1.9 {simple namespace elements} {
namespace eval ns1 {
variable v1 1
proc p1 {a} {variable v1; list $a $v1}
p1 3
}
} {3 1}
test namespace-1.10 {commands in a namespace} {
namespace eval ns1 {
info commands [namespace current]::*
}
} {::ns1::p1}
test namespace-1.11 {variables in a namespace} {
namespace eval ns1 {
info vars [namespace current]::*
}
} {::ns1::v1}
test namespace-1.12 {global vars are separate from locals vars} {
set v1 2
list [ns1::p1 123] [set ns1::v1] [set ::v1]
} {{123 1} 1 2}
test namespace-1.13 {add to an existing namespace} {
namespace eval ns1 {
variable v2 22
proc p2 {script} {variable v2; eval $script}
p2 {return $v2}
}
} 22
test namespace-1.14 {commands in a namespace} {
lsort [namespace eval ns1 {info commands [namespace current]::*}]
} {::ns1::p1 ::ns1::p2}
test namespace-1.15 {variables in a namespace} {
lsort [namespace eval ns1 {info vars [namespace current]::*}]
} {::ns1::v1 ::ns1::v2}
# Tcl produces fully scoped names here
test namespace-1.16 {variables in a namespace} jim {
lsort [info vars ns1::*]
} {ns1::v1 ns1::v2}
test namespace-1.17 {commands in a namespace are hidden} -body {
v2 {return 3}
} -returnCodes error -result {invalid command name "v2"}
test namespace-1.18 {using namespace qualifiers} {
ns1::p2 {return 44}
} 44
test namespace-1.19 {using absolute namespace qualifiers} {
::ns1::p2 {return 55}
} 55
test namespace-1.20 {variables in a namespace are hidden} -body {
set v2
} -returnCodes error -result {can't read "v2": no such variable}
test namespace-1.21 {using namespace qualifiers} {
list $ns1::v1 $ns1::v2
} {1 22}
test namespace-1.22 {using absolute namespace qualifiers} {
list $::ns1::v1 $::ns1::v2
} {1 22}
test namespace-1.23 {variables can be accessed within a namespace} {
ns1::p2 {
variable v1
variable v2
list $v1 $v2
}
} {1 22}
test namespace-1.24 {setting global variables} {
ns1::p2 {
variable v1
set v1 new
}
namespace eval ns1 {
variable v1
variable v2
list $v1 $v2
}
} {new 22}
test namespace-1.25 {qualified variables don't need a global declaration} {
namespace eval ns2 { variable x 456 }
set cmd {set ::ns2::x}
ns1::p2 "$cmd some-value"
set ::ns2::x
} {some-value}
test namespace-1.26 {namespace qualifiers are okay after $'s} {
namespace eval ns1 { variable x; variable y; set x 12; set y 34 }
set cmd {list $::ns1::x $::ns1::y}
list [ns1::p2 $cmd] [eval $cmd]
} {{12 34} {12 34}}
test namespace-1.27 {can create commands with null names} {
proc ns1:: {args} {return $args}
ns1:: x
} {x}
unset -nocomplain ns1::x ns1::y
# -----------------------------------------------------------------------
# TEST: using "info" in namespace contexts
# -----------------------------------------------------------------------
test namespace-2.1 {querying: info commands} {
lsort [ns1::p2 {info commands [namespace current]::*}]
} {::ns1:: ::ns1::p1 ::ns1::p2}
test namespace-2.2 {querying: info procs} {
lsort [ns1::p2 {info procs}]
} {{} p1 p2}
# Tcl produces fully scoped names here
test namespace-2.3 {querying: info vars} jim {
lsort [info vars ns1::*]
} {ns1::v1 ns1::v2}
test namespace-2.4 {querying: info vars} {
lsort [ns1::p2 {info vars [namespace current]::*}]
} {::ns1::v1 ::ns1::v2}
test namespace-2.5 {querying: info locals} {
lsort [ns1::p2 {info locals}]
} {script}
test namespace-2.6 {querying: info exists} {
ns1::p2 {info exists v1}
} {0}
test namespace-2.7 {querying: info exists} {
ns1::p2 {info exists v2}
} {1}
test namespace-2.8 {querying: info args} {
info args ns1::p2
} {script}
test namespace-2.9 {querying: info body} {
string trim [info body ns1::p1]
} {variable v1; list $a $v1}
# -----------------------------------------------------------------------
# TEST: namespace qualifiers, namespace tail
# -----------------------------------------------------------------------
test namespace-3.1 {usage for "namespace qualifiers"} {
list [catch "namespace qualifiers" msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-3.2 {querying: namespace qualifiers} {
list [namespace qualifiers ""] \
[namespace qualifiers ::] \
[namespace qualifiers x] \
[namespace qualifiers ::x] \
[namespace qualifiers foo::x] \
[namespace qualifiers ::foo::bar::xyz]
} {{} {} {} {} foo ::foo::bar}
test namespace-3.3 {usage for "namespace tail"} {
list [catch "namespace tail" msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-3.4 {querying: namespace tail} {
list [namespace tail ""] \
[namespace tail ::] \
[namespace tail x] \
[namespace tail ::x] \
[namespace tail foo::x] \
[namespace tail ::foo::bar::xyz]
} {{} {} x x x xyz}
# -----------------------------------------------------------------------
# TEST: namespace hierarchy
# -----------------------------------------------------------------------
test namespace-5.1 {define nested namespaces} {
set test_ns_var_global "var in ::"
proc test_ns_cmd_global {} {return "cmd in ::"}
namespace eval nsh1 {
set test_ns_var_hier1 "particular to hier1"
proc test_ns_cmd_hier1 {} {return "particular to hier1"}
proc test_ns_show {} {return "[namespace current]: 1"}
namespace eval nsh2 {
set test_ns_var_hier2 "particular to hier2"
proc test_ns_cmd_hier2 {} {return "particular to hier2"}
proc test_ns_show {} {return "[namespace current]: 2"}
namespace eval nsh3a {}
namespace eval nsh3b {}
}
namespace eval nsh2a {}
namespace eval nsh2b {}
}
} {}
test namespace-5.2 {namespaces can be nested} {
list [namespace eval nsh1 {namespace current}] \
[namespace eval nsh1 {
namespace eval nsh2 {namespace current}
}]
} {::nsh1 ::nsh1::nsh2}
test namespace-5.3 {namespace qualifiers work in namespace command} {
list [namespace eval ::nsh1 {namespace current}] \
[namespace eval nsh1::nsh2 {namespace current}] \
[namespace eval ::nsh1::nsh2 {namespace current}]
} {::nsh1 ::nsh1::nsh2 ::nsh1::nsh2}
test namespace-5.4 {nested namespaces can access global namespace} {
list [namespace eval nsh1 {set ::test_ns_var_global}] \
[namespace eval nsh1 {test_ns_cmd_global}] \
[namespace eval nsh1::nsh2 {set ::test_ns_var_global}] \
[namespace eval nsh1::nsh2 {test_ns_cmd_global}]
} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}}
test namespace-5.6 {commands in different namespaces don't conflict} {
list [nsh1::test_ns_show] \
[nsh1::nsh2::test_ns_show]
} {{::nsh1: 1} {::nsh1::nsh2: 2}}
test namespace-5.7 {nested namespaces don't see variables in parent} {
set cmd {
namespace eval nsh1::nsh2 {set test_ns_var_hier1}
}
list [catch $cmd msg] $msg
} {1 {can't read "test_ns_var_hier1": no such variable}}
test namespace-5.8 {nested namespaces don't see commands in parent} {
set cmd {
namespace eval nsh1::nsh2 {test_ns_cmd_hier1}
}
list [catch $cmd msg] $msg
} {1 {invalid command name "test_ns_cmd_hier1"}}
test namespace-5.18 {usage for "namespace parent"} {
list [catch {namespace parent x y} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-5.20 {querying namespace parent} {
list [namespace eval :: {namespace parent}] \
[namespace eval nsh1 {namespace parent}] \
[namespace eval nsh1::nsh2 {namespace parent}] \
[namespace eval nsh1::nsh2::nsh3a {namespace parent}] \
} {{} :: ::nsh1 ::nsh1::nsh2}
test namespace-5.21 {querying namespace parent for explicit namespace} {
list [namespace parent ::] \
[namespace parent nsh1] \
[namespace parent nsh1::nsh2] \
[namespace parent nsh1::nsh2::nsh3a]
} {{} :: ::nsh1 ::nsh1::nsh2}
# -----------------------------------------------------------------------
# TEST: name resolution and caching
# -----------------------------------------------------------------------
test namespace-6.1 {relative ns names only looked up in current ns} {
namespace eval tns1 {}
namespace eval tns2 {}
namespace eval tns2::test_ns_cache3 {}
set trigger {
namespace eval tns2 {namespace current}
}
set trigger2 {
namespace eval tns2::test_ns_cache3 {namespace current}
}
list [namespace eval tns1 $trigger] \
[namespace eval tns1 $trigger2]
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
test namespace-6.2 {relative ns names only looked up in current ns} {
namespace eval tns1::tns2 {}
list [namespace eval tns1 $trigger] \
[namespace eval tns1 $trigger2]
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
test namespace-6.3 {relative ns names only looked up in current ns} {
namespace eval tns1::tns2::test_ns_cache3 {}
list [namespace eval tns1 $trigger] \
[namespace eval tns1 $trigger2]
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
test namespace-6.4 {relative ns names only looked up in current ns} {
namespace delete tns1::tns2
list [namespace eval tns1 $trigger] \
[namespace eval tns1 $trigger2]
} {::tns1::tns2 ::tns1::tns2::test_ns_cache3}
test namespace-6.5 {define test commands} {
proc testcmd {} {
return "global version"
}
namespace eval tns1 {
proc trigger {} {
testcmd
}
}
tns1::trigger
} {global version}
test namespace-6.6 {one-level check for command shadowing} {
proc tns1::testcmd {} {
return "cache1 version"
}
tns1::trigger
} {cache1 version}
test namespace-6.7 {renaming commands changes command epoch} {
namespace eval tns1 {
rename testcmd testcmd_new
}
tns1::trigger
} {global version}
test namespace-6.8 {renaming back handles shadowing} {
namespace eval tns1 {
rename testcmd_new testcmd
}
tns1::trigger
} {cache1 version}
test namespace-6.9 {deleting commands changes command epoch} {
namespace eval tns1 {
rename testcmd ""
}
tns1::trigger
} {global version}
test namespace-6.10 {define test namespaces} {
namespace eval tns2 {
proc testcmd {} {
return "global cache2 version"
}
}
namespace eval tns1 {
proc trigger {} {
tns2::testcmd
}
}
namespace eval tns1::tns2 {
proc trigger {} {
testcmd
}
}
list [tns1::trigger] [tns1::tns2::trigger]
} {{global cache2 version} {global version}}
test namespace-6.11 {commands affect all parent namespaces} {
proc tns1::tns2::testcmd {} {
return "cache2 version"
}
list [tns1::trigger] [tns1::tns2::trigger]
} {{cache2 version} {cache2 version}}
# -----------------------------------------------------------------------
# TEST: uplevel/upvar across namespace boundaries
# -----------------------------------------------------------------------
# Note that Tcl behaves a little differently for uplevel and upvar
test namespace-7.1 {uplevel in namespace eval} jim {
set x 66
namespace eval uns1 {
variable y 55
set x 33
uplevel 1 set x
}
} {66}
test namespace-7.2 {upvar in ns proc} jim {
proc uns1::getvar {v} {
variable y
upvar $v var
list $var $y
}
uns1::getvar x
} {66 55}
# -----------------------------------------------------------------------
# TEST: scoped values
# -----------------------------------------------------------------------
test namespace-10.1 {define namespace for scope test} {
namespace eval ins1 {
variable x "x-value"
proc show {args} {
return "show: $args"
}
proc do {args} {
return [eval $args]
}
list [set x] [show test]
}
} {x-value {show: test}}
test namespace-10.2 {command "namespace code" requires one argument} {
list [catch {namespace code} msg] $msg
} {1 {wrong # args: should be "namespace code arg"}}
test namespace-10.3 {command "namespace code" requires one argument} {
list [catch {namespace code first "second arg" third} msg] $msg
} {1 {wrong # args: should be "namespace code arg"}}
test namespace-10.4 {command "namespace code" gets current namesp context} {
namespace eval ins1 {
namespace code {"1 2 3" "4 5" 6}
}
} {::namespace inscope ::ins1 {"1 2 3" "4 5" 6}}
test namespace-10.5 {with one arg, first "scope" sticks} {
set sval [namespace eval ins1 {namespace code {one two}}]
namespace code $sval
} {::namespace inscope ::ins1 {one two}}
test namespace-10.6 {with many args, each "scope" adds new args} {
set sval [namespace eval ins1 {namespace code {one two}}]
namespace code "$sval three"
} {::namespace inscope ::ins1 {one two} three}
test namespace-10.7 {scoped commands work with eval} {
set cref [namespace eval ins1 {namespace code show}]
list [eval $cref "a" "b c" "d e f"]
} {{show: a b c d e f}}
test namespace-10.8 {scoped commands execute in namespace context} {
set cref [namespace eval ins1 {
namespace code {variable x; set x "some new value"}
}]
list [set ins1::x] [eval $cref] [set ins1::x]
} {x-value {some new value} {some new value}}
test namespace-11.1 {command caching} {
proc cmd1 {} { return global }
set result {}
namespace eval ns1 {
proc cmd1 {} { return ns1 }
proc cmd2 {} {
uplevel 1 cmd1
}
lappend ::result [cmd2]
}
lappend result [ns1::cmd2]
} {ns1 global}
foreach cmd [info commands test_ns_*] {
rename $cmd ""
}
catch {rename cmd {}}
catch {rename cmd1 {}}
catch {rename cmd2 {}}
catch {rename ncmd {}}
catch {rename ncmd1 {}}
catch {rename ncmd2 {}}
catch {unset cref}
catch {unset trigger}
catch {unset trigger2}
catch {unset sval}
catch {unset msg}
catch {unset x}
catch {unset test_ns_var_global}
catch {unset cmd}
catch {eval namespace delete [namespace children :: test_ns_*]}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:

323
debuggers/openocd/jimtcl/tests/parse.test Normal file
View File

@ -0,0 +1,323 @@
source [file dirname [info script]]/testing.tcl
test parse-1.1 "Quoted closing bracket" {
set x [string length "]"]
} {1}
test parse-1.2 "Quoted opening bracket" {
set x [string length "\["]
} {1}
test parse-1.3 "Quoted open brace" {
set x [string length "\{"]
} {1}
test parse-1.4 "Quoted open brace via var" {
set lb \{
set x [string length "$lb"]
} {1}
test parse-1.5 "Braced bracket" {
set x [string length {]}]
} {1}
test parse-1.6 "Dict sugar" -body {
unset -nocomplain a
array set a {a 1 b 2 c 3}
set x $a(
} -returnCodes error -match glob -result "*"
test parse-1.8 "Dict sugar" {
unset -nocomplain a
array set a {a 1 b 2 c 3}
set x $a([set y b])
} 2
test parse-1.9 "Backslash newline" {
set x 123;\
set y 456
list $x $y
} {123 456}
test parse-1.10 "Backslash newline in quotes" {
set x "abc\
def"
} "abc def"
test parse-1.11 "Backslash newline in quotes after var" {
set y 1
set x "abc$y\
def"
} "abc1 def"
test parse-1.12 "Backslash newline in quotes after var" {
set y 1
set x "abc$y\
def"
} "abc1 def"
test parse-1.13 "Newline in quotes" {
set y 1
set x "abc
def"
} "abc\ndef"
test parse-1.14 "Newline in quotes after var" {
set y 1
set x "abc$y
def"
} "abc1\ndef"
test parse-1.15 "Space in quotes" {
set y 1
set x "abc def"
} "abc def"
test parse-1.16 "Space in quotes after var" {
set y 1
set x "abc${y} def"
} "abc1 def"
test parse-1.17 "Command and var in quotes" {
set y 1
set x "[set z 2][set y]"
} 21
test parse-1.18 "Command and var in bare context" {
set y 1
set x [set z 2][set y]
} 21
test parse-1.19 "Lone dollar sign in quotes" {
set y 1
set x "6$[set y]"
} 6\$1
test parse-1.20 "Command and var in bare context" {
set y 1
set x 6$[set y]
} 6\$1
test parse-1.21 "Comment" {
set y 1
# A comment one a line
set x [set y] ;# comment after semicolon
} 1
test parse-1.22 "# char" {
set y 1
append y #
set x "[set y]#"
} {1##}
test parse-1.23 "newline in command" {
set y 1
set z 2
set x [incr y
incr z]
list $x $y $z
} {3 2 3}
test parse-1.24 "semicolon in command" {
set x [list a; list b c; list d e f]
} {d e f}
# Note that Tcl complains about the missing brace here
# while Jim ignores it
test parse-1.25 "missing brace in var" jim {
unset -nocomplain a
set a 3
set brace \{
set x [subst \$${brace}a]
} 3
test parse-1.26 "newline in braced var" {
set "a\nb" var1
set x ${a
b}
} var1
test parse-1.27 "backslash escape in dict sugar" {
unset -nocomplain a
set a(b\x55d) 5
set x $a(b\x55d)
} 5
test parse-1.28 "nested dict sugar" {
unset -nocomplain a b
set a(V) 5
set b(5) five
set x $b($a(V))
} five
set dq {"}
set script "set x ${dq}hello"
test parse-1.29 "missing quote" jim {
eval $script
} hello
test parse-1.30 "missing quote" {
info complete $script
} 0
test parse-1.31 "backslash newline in bare context" {
list abc\
123
} {abc 123}
test parse-1.32 "comment as last line of script" {
set script {set x 3; # this is a comment}
eval $script
} 3
test parse-1.33 "upper case hex escapes" {
list \x4A \x4F \x3C
} {J O <}
test parse-1.34 "octal escapes" {
list \112 \117 \074
} {J O <}
test parse-1.35 "invalid hex escape" {
list \xZZ
} xZZ
test parse-1.36 "unicode escape" jim {
list \u00b5
} \xc2\xb5
test parse-1.37 "invalid unicode escape after unicode" jim {
list \ub5x
} \xc2\xb5x
test parse-1.38 "invalid unicode escape" {
list \ux
} ux
test parse-1.39 "octal escape followed by invalid" {
list \76x
} >x
test parse-1.40 "list containing quoted trailing backslash" jim {
set x "abc \"def\\"
lindex $x 1
} def\\
test parse-1.41 "list containing quoted newline" {
set x {abc "def
ghi"}
lindex $x 1
} def\nghi
test parse-1.42 "list containing missing quote" jim {
set x {abc "def}
lindex $x 1
} def
test parse-1.43 "list containing trailing backslash" {
set x "abc def\\"
lindex $x 1
} def\\
test parse-1.44 "list creation" {
list "a{ }d"
} {{a{ }d}}
test parse-1.45 "spaces before expr function args" {
expr {round (3.2)}
} 3
test parse-1.46 "expr function missing paren" {
catch {expr {round 3.2}}
} 1
test parse-1.47 "backslash newline in quotes" {
# spaces
set x "abc\
def"
} "abc def"
test parse-1.48 "backslash newline in quotes" {
# tabs
set x "abc\
def"
} "abc def"
test parse-1.49 "backslash newline in quotes" {
# tabs plus newline
set x "abc\
def"
} "abc \ndef"
test parse-1.50 "backslash newline in quotes" {
# tabs plus newline
set x "abc\
def"
} "abc def"
test parse-1.51 "special chars in dict sugar" {
unset -nocomplain a
set a(x$) 5
array names a
} {{x$}}
test parse-1.52 "special chars in dict sugar" {
set x $a(x$)
} 5
test parse-1.53 "special chars in dict sugar" {
unset -nocomplain a
set a(x\[) 5
array names a
} {{x[}}
test parse-1.54 "special chars in dict sugar" {
set x $a(x\[)
} 5
test parse-1.55 "special chars in dict sugar" {
unset -nocomplain a
set a(x\() 5
array names a
} {x(}
test parse-1.56 "special chars in dict sugar" {
set x $a(x\()
} 5
test parse-1.57 "special chars in dict sugar" {
unset -nocomplain a
set a(x() 5
array names a
} {x(}
test parse-1.58 "special chars in dict sugar" {
set x $a(x()
} 5
test parse-1.59 "special chars in dict sugar" {
unset -nocomplain a
set a(x") 5
lindex [array names a] 0
} {x"}
test parse-1.60 "special chars in dict sugar" {
set x $a(x")
} 5
test parse-1.61 "quote in command" {
set x [list \\" x]
lindex $x end
} x
test parse-1.62 "quoted orphan dollar sign" {
set x "x$"
} {x$}
test parse-1.63 "unquoted dollar sign" {
set x x$
} {x$}
testreport

137
debuggers/openocd/jimtcl/tests/perf.test Normal file
View File

@ -0,0 +1,137 @@
source [file dirname [info script]]/testing.tcl
needs constraint manual
set iterations 10000
set version [info patchlevel]
proc bench {name cmd} {
if {[catch {
set t [time $cmd 2]
set ms [format %.0f [expr {[lindex $t 0] / 1000}]]
}]} {
set ms ?
}
puts "$::version: $name ${ms}ms"
}
proc set_dict_sugar {} {
for {set i 0} {$i < $::iterations} {incr i} {
set a(b) $i
}
}
# Note that this case does not benefit from the dict sugar
# speedup since a($b) needs to be interpolated and reparsed every time
proc set_var_dict_sugar {} {
set b b
for {set i 0} {$i < $::iterations} {incr i} {
set a($b) $i
}
}
proc set_var_dict {} {
set b b
for {set i 0} {$i < $::iterations} {incr i} {
dict set a $b $i
}
}
proc read_file {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
}
close $f
}
proc read_file_split {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
split $buf \t
}
close $f
}
proc read_file_split_assign_foreach {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
foreach {info(chan) info(datetime) info(duration) info(title) subtitle_genre info(desc) info(rating) dummy} [split $buf \t] {break}
}
close $f
}
proc read_file_split_assign_foreach_dict {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
foreach {chan datetime duration title subtitle_genre desc rating dummy} [split $buf \t] {break}
dict set info chan $chan
dict set info duration $duration
dict set info title $title
dict set info subtitle_genre $subtitle_genre
dict set info desc $desc
dict set info rating $rating
}
close $f
}
proc read_file_split_assign_foreach_dictsugar {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
foreach {chan datetime duration title subtitle_genre desc rating dummy} [split $buf \t] {break}
set info(chan) $chan
set info(duration) $duration
set info(title) $title
set info(subtitle_genre) $subtitle_genre
set info(desc) $desc
set info(rating) $rating
}
close $f
}
proc read_file_split_assign_foreach_simple {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
foreach {chan datetime duration title subtitle_genre desc rating dummy} [split $buf \t] {break}
}
close $f
}
proc read_file_split_assign_lindex {file} {
set f [open $file]
while {[gets $f buf] >= 0} {
set split [split $buf \t]
set info(chan) [lindex $split 0]
set info(datetime) [lindex $split 1]
set info(duration) [lindex $split 2]
set info(title) [lindex $split 3]
set info(subtitle_genre) [lindex $split 4]
set info(desc) [lindex $split 5]
set info(rating) [lindex $split 6]
}
close $f
}
# Create a really big file
set f [open test.in w]
for {set i 0} {$i < $::iterations} {incr i} {
puts $f "a\tb\tc\te\tf\tg\th\ti\tj\tk"
}
close $f
bench "set dictsugar" {set_dict_sugar}
bench "set var dictsugar" {set_var_dict_sugar}
bench "set var dict" {set_var_dict}
# Read once before testing perf
read_file test.in
bench "read file" {read_file test.in}
bench "read file split" {read_file_split test.in}
bench "foreach: simple" {read_file_split_assign_foreach_simple test.in}
bench "foreach: direct dictsugar" {read_file_split_assign_foreach test.in}
bench "foreach: dict cmd" {read_file_split_assign_foreach_dict test.in}
bench "foreach: assign to dictsugar" {read_file_split_assign_foreach_dictsugar test.in}
bench "foreach: assign to dictsugar via lindex" {read_file_split_assign_lindex test.in}
file delete test.in
# testreport

55
debuggers/openocd/jimtcl/tests/pid.test Normal file
View File

@ -0,0 +1,55 @@
# Commands covered: pid
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pid.test,v 1.6 2000/04/10 17:19:03 ericm Exp $
source [file dirname [info script]]/testing.tcl
needs cmd pid posix
needs cmd exec
catch {package require regexp}
testConstraint regexp [expr {[info commands regexp] ne {}}]
testConstraint socket [expr {[info commands socket] ne {}}]
testConstraint getpid [expr {[catch pid] == 0}]
file delete test1
test pid-1.1 {pid command} {regexp getpid} {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {regexp socket} {
set f [open {| echo foo | cat >test1} w]
set pids [pid $f]
close $f
catch {removeFile test1}
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
[regexp {^[0-9]+$} [lindex $pids 1]] \
[expr {[lindex $pids 0] == [lindex $pids 1]}]
} {2 1 1 0}
test pid-1.3 {pid command} socket {
set f [open test1 w]
set pids [pid $f]
close $f
set pids
} {}
test pid-1.4 {pid command} jim {
list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?chan?"}}
test pid-1.5 {pid command} {
list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}
# cleanup
file delete test1
testreport

156
debuggers/openocd/jimtcl/tests/prefix.test Normal file
View File

@ -0,0 +1,156 @@
# Commands covered: tcl::prefix
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
needs cmd tcl::prefix prefix
testConstraint namespace [expr {[info commands namespace] ne ""}]
test string-26.1 {tcl::prefix, too few args} -body {
tcl::prefix match a
} -returnCodes 1 -match glob -result {wrong # args: should be "tcl::prefix match ?options*? table string"}
test string-26.2 {tcl::prefix, bad args} -body {
tcl::prefix match a b c
} -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message}
test string-26.2.1 {tcl::prefix, empty table} -body {
tcl::prefix match {} foo
} -returnCodes 1 -result {bad option "foo": no valid options}
test string-26.3.1 {tcl::prefix, bad args} -body {
tcl::prefix match -error "x" -exact str1 str2
} -returnCodes 1 -match glob -result *
test string-26.3.2 {tcl::prefix, bad args} -body {
tcl::prefix match -error str1 str2
} -returnCodes 1 -result {missing error options}
test string-26.4 {tcl::prefix, bad args} -body {
tcl::prefix match -message str1 str2
} -returnCodes 1 -result {missing message}
test string-26.5 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} cepa
} cepa
test string-26.6 {tcl::prefix} {
tcl::prefix match {apa bepa cepa depa} be
} bepa
test string-26.7 {tcl::prefix} -body {
tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
test string-26.8 {tcl::prefix} -body {
tcl::prefix match -message switch {apa bear bepa depa} be
} -returnCodes 1 -result {ambiguous switch "be": must be apa, bear, bepa, or depa}
test string-26.9 {tcl::prefix} -body {
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
test string-26.10 {tcl::prefix} -body {
tcl::prefix match -error {-level 1} {apa bear bepa depa} be
} -returnCodes 2 -result {ambiguous option "be": must be apa, bear, bepa, or depa}
test string-27.1 {tcl::prefix all, too few args} -body {
tcl::prefix all a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
test string-27.2 {tcl::prefix all, bad args} -body {
tcl::prefix all a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"}
test string-27.4 {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} c
} cepa
test string-27.5 {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} cepa
} cepa
test string-27.6 {tcl::prefix all} {
tcl::prefix all {apa bepa cepa depa} cepax
} {}
test string-27.7 {tcl::prefix all} {
tcl::prefix all {apa aska appa} a
} {apa aska appa}
test string-27.8 {tcl::prefix all} {
tcl::prefix all {apa aska appa} ap
} {apa appa}
test string-27.9 {tcl::prefix all} {
tcl::prefix all {apa aska appa} p
} {}
test string-27.10 {tcl::prefix all} {
tcl::prefix all {apa aska appa} {}
} {apa aska appa}
test string-28.1 {tcl::prefix longest, too few args} -body {
tcl::prefix longest a
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
test string-28.2 {tcl::prefix longest, bad args} -body {
tcl::prefix longest a b c
} -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"}
test string-28.4 {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} c
} cepa
test string-28.5 {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} cepa
} cepa
test string-28.6 {tcl::prefix longest} {
tcl::prefix longest {apa bepa cepa depa} cepax
} {}
test string-28.7 {tcl::prefix longest} {
tcl::prefix longest {apa aska appa} a
} a
test string-28.8 {tcl::prefix longest} {
tcl::prefix longest {apa aska appa} ap
} ap
test string-28.9 {tcl::prefix longest} {
tcl::prefix longest {apa bska appa} a
} ap
test string-28.10 {tcl::prefix longest} {
tcl::prefix longest {apa bska appa} {}
} {}
test string-28.11 {tcl::prefix longest} {
tcl::prefix longest {{} bska appa} {}
} {}
test string-28.12 {tcl::prefix longest} {
tcl::prefix longest {apa {} appa} {}
} {}
test string-28.13 {tcl::prefix longest} {
# Test UTF8 handling
tcl::prefix longest {ax\x90 bep ax\x91} a
} ax
test string-29.1 {tcl::prefix from another namespace} namespace {
namespace eval abc {
tcl::prefix longest {apa bepa cepa depa} cepa
}
} cepa
testreport

127
debuggers/openocd/jimtcl/tests/proc-new.test Normal file
View File

@ -0,0 +1,127 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd array
proc aproc {} {
list
}
proc bproc {b} {
list b $b
}
proc cproc {b c} {
list b $b c $c
}
proc dproc {b c {d dd}} {
list b $b c $c d $d
}
proc eproc {b c {d dd} e} {
list b $b c $c d $d e $e
}
proc fproc {b c {d dd} args} {
list b $b c $c d $d args $args
}
proc gproc {b c {d dd} args e} {
list b $b c $c d $d args $args e $e
}
proc hproc {{a aa} args} {
list a $a args $args
}
proc iproc {{a aa} b {c cc}} {
list a $a b $b c $c
}
proc jproc {args {a aa} b {c cc} d} {
list a $a b $b c $c d $d args $args
}
set n 1
foreach {proc params result} {
aproc {} {}
bproc B {b B}
cproc {B C} {b B c C}
dproc {B C} {b B c C d dd}
dproc {B C D} {b B c C d D}
eproc {B C D E} {b B c C d D e E}
eproc {B C E} {b B c C d dd e E}
fproc {B C} {b B c C d dd args {}}
fproc {B C D} {b B c C d D args {}}
fproc {B C D E} {b B c C d D args E}
fproc {B C D E F} {b B c C d D args {E F}}
gproc {B C E} {b B c C d dd args {} e E}
gproc {B C D E} {b B c C d D args {} e E}
gproc {B C D X E} {b B c C d D args X e E}
gproc {B C D X Y Z E} {b B c C d D args {X Y Z} e E}
hproc {} {a aa args {}}
hproc {A} {a A args {}}
hproc {A X Y Z} {a A args {X Y Z}}
iproc {B} {a aa b B c cc}
iproc {A B} {a A b B c cc}
iproc {A B C} {a A b B c C}
jproc {B D} {a aa b B c cc d D args {}}
jproc {A B D} {a A b B c cc d D args {}}
jproc {A B C D} {a A b B c C d D args {}}
jproc {E F A B C D} {a A b B c C d D args {E F}}
} {
test proc-1.$n "Proc args combos" [list $proc {*}$params] $result
incr n
}
proc onearg_search {{nocase ""} value list} {
lsearch {*}$nocase $list $value
}
proc multiarg_search {args value list} {
lsearch {*}$args $list $value
}
test proc-2.1 "Real test of optional switches" {
onearg_search c {A a B b C c D d}
} 5
test proc-2.2 "Real test of optional switches" {
onearg_search -nocase c {A a B b C c D d}
} 4
test proc-2.3 "Real test of optional switches" {
multiarg_search -glob c* {A a B b C c D d}
} 5
test proc-2.4 "Real test of optional switches" {
multiarg_search -nocase -glob c* {A a B b C c D d}
} 4
test proc-3.1 "Rename optional args" {
proc a {b {args vars}} {
}
catch {a} msg
set msg
} {wrong # args: should be "a b ?vars ...?"}
test proc-3.2 "Rename optional args" {
proc a {b {args vars} c} {
}
catch {a} msg
set msg
} {wrong # args: should be "a b ?vars ...? c"}
test proc-3.2 "Rename optional args" {
proc a {b {args vars}} {
return $vars
}
a B C D
} {C D}
test proc-3.3 "dict sugar arg" {
proc a {b(c)} { return $b}
a 4
} {c 4}
test proc-3.4 "invalid upref in rightargs" {
proc a {{x 2} &b} { return $b}
unset -nocomplain B
catch {a B}
} 1
testreport

380
debuggers/openocd/jimtcl/tests/proc.test Normal file
View File

@ -0,0 +1,380 @@
# Commands covered: proc, return, global
#
# This file, proc-old.test, includes the original set of tests for Tcl's
# proc, return, and global commands. There is now a new file proc.test
# that contains tests for the tclProc.c source file.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: proc-old.test,v 1.6 2000/04/10 17:19:03 ericm Exp $
source [file dirname [info script]]/testing.tcl
needs constraint jim
needs cmd array
catch {rename t1 ""}
catch {rename foo ""}
proc tproc {} {return a; return b}
test proc-old-1.1 {simple procedure call and return} {tproc} a
proc tproc x {
set x [expr $x+1]
return $x
}
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
test proc-old-1.3 {simple procedure call and return} {
proc tproc {} {return foo}
} {tproc}
test proc-old-1.4 {simple procedure call and return} {
proc tproc {} {return}
tproc
} {}
proc tproc1 {a} {incr a; return $a}
proc tproc2 {a b} {incr a; return $a}
test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
list [tproc1 123] [tproc2 456 789]
} {124 457}
test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
set x {}
proc tproc {} {} ;# body is shared with x
list [tproc] [append x foo]
} {{} foo}
test proc-old-2.1 {local and global variables} {
proc tproc x {
set x [expr $x+1]
return $x
}
set x 42
list [tproc 6] $x
} {7 42}
test proc-old-2.2 {local and global variables} {
proc tproc x {
set y [expr $x+1]
return $y
}
set y 18
list [tproc 6] $y
} {7 18}
test proc-old-2.3 {local and global variables} {
proc tproc x {
global y
set y [expr $x+1]
return $y
}
set y 189
list [tproc 6] $y
} {7 7}
test proc-old-2.4 {local and global variables} {
proc tproc x {
global y
return [expr $x+$y]
}
set y 189
list [tproc 6] $y
} {195 189}
catch {unset _undefined_}
test proc-old-2.5 {local and global variables} {
proc tproc x {
global _undefined_
return $_undefined_
}
list [catch {tproc xxx} msg] $msg
} {1 {can't read "_undefined_": no such variable}}
test proc-old-2.6 {local and global variables} {
set a 114
set b 115
global a b
list $a $b
} {114 115}
proc do {cmd} {eval $cmd}
test proc-old-3.1 {local and global arrays} {
catch {unset a}
set a(0) 22
list [catch {do {global a; set a(0)}} msg] $msg
} {0 22}
test proc-old-3.2 {local and global arrays} {
catch {unset a}
set a(x) 22
list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
} {0 newValue newValue}
test proc-old-3.3 {local and global arrays} {
catch {unset a}
set a(x) 22
set a(y) 33
list [catch {do {global a; unset a(y)}; array names a} msg] $msg
} {0 x}
test proc-old-3.4 {local and global arrays} {
catch {unset a}
set a(x) 22
set a(y) 33
list [catch {do {global a; unset a; info exists a}} msg] $msg \
[info exists a]
} {0 0 0}
test proc-old-3.5 {local and global arrays} {
catch {unset a}
set a(x) 22
set a(y) 33
list [catch {do {global a; unset a(y); array names a}} msg] $msg
} {0 x}
catch {unset a}
test proc-old-3.6 {local and global arrays} {
catch {unset a}
set a(x) 22
set a(y) 33
do {global a; do {global a; unset a}; set a(z) 22}
list [catch {array names a} msg] $msg
} {0 z}
test proc-old-3.1 {arguments and defaults} {
proc tproc {x y z} {
return [list $x $y $z]
}
tproc 11 12 13
} {11 12 13}
test proc-old-3.2 {arguments and defaults} {
proc tproc {x y z} {
return [list $x $y $z]
}
list [catch {tproc 11 12} msg]
} {1}
test proc-old-3.3 {arguments and defaults} {
proc tproc {x y z} {
return [list $x $y $z]
}
list [catch {tproc 11 12 13 14} msg]
} {1}
test proc-old-3.4 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
tproc 11 12 13
} {11 12 13}
test proc-old-3.5 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
tproc 11 12
} {11 12 z-default}
test proc-old-3.6 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
tproc 11
} {11 y-default z-default}
test proc-old-3.7 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
list [catch {tproc} msg]
} {1}
# Note: This requires new TIP #288 support
test proc-old-3.8 {arguments and defaults} {
list [catch {
proc tproc {x {y y-default} z} {
return [list $x $y $z]
}
tproc 2 3
} msg] $msg
} {0 {2 y-default 3}}
test proc-old-3.9 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
tproc 2 3 4 5
} {2 3 {4 5}}
test proc-old-3.10 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
tproc 2 3
} {2 3 {}}
test proc-old-3.11 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
tproc 2
} {2 y-default {}}
test proc-old-3.12 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
list [catch {tproc} msg]
} {1}
test proc-old-4.1 {variable numbers of arguments} {
proc tproc args {return $args}
tproc
} {}
test proc-old-4.2 {variable numbers of arguments} {
proc tproc args {return $args}
tproc 1 2 3 4 5 6 7 8
} {1 2 3 4 5 6 7 8}
test proc-old-4.3 {variable numbers of arguments} {
proc tproc args {return $args}
tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
} {1 {2 3} {4 {5 6} {{{7}}}} 8}
test proc-old-4.4 {variable numbers of arguments} {
proc tproc {x y args} {return $args}
tproc 1 2 3 4 5 6 7
} {3 4 5 6 7}
test proc-old-4.5 {variable numbers of arguments} {
proc tproc {x y args} {return $args}
tproc 1 2
} {}
test proc-old-4.6 {variable numbers of arguments} {
proc tproc {x missing args} {return $args}
list [catch {tproc 1} msg]
} {1}
test proc-old-5.1 {error conditions} {
list [catch {proc} msg]
} {1}
test proc-old-5.2 {error conditions} {
list [catch {proc tproc b} msg]
} {1}
test proc-old-5.3 {error conditions} {
list [catch {proc tproc b c d e} msg]
} {1}
test proc-old-5.6 {error conditions} {
list [catch {proc tproc {{} y} {return foo}} msg] $msg
} {1 {argument with no name}}
test proc-old-5.7 {error conditions} {
list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
} {1 {too many fields in argument specifier "x 1 2"}}
test proc-old-5.8 {error conditions} {
catch {return}
} 2
test proc-old-5.9 {error conditions} {
list [catch {global} msg] $msg
} {1 {wrong # args: should be "global varName ?varName ...?"}}
proc tproc {} {
set a 22
global a
}
test proc-old-5.10 {error conditions} {
list [catch {tproc} msg] $msg
} {1 {variable "a" already exists}}
test proc-old-5.11 {error conditions} {
catch {rename tproc {}}
catch {
proc tproc {x {} z} {return foo}
}
list [catch {tproc 1} msg] $msg
} {1 {invalid command name "tproc"}}
test proc-old-5.12 {error conditions} {
proc tproc {} {
set a 22
error "error in procedure"
return
}
list [catch tproc msg] $msg
} {1 {error in procedure}}
# The tests below will really only be useful when run under Purify or
# some other system that can detect accesses to freed memory...
test proc-old-6.1 {procedure that redefines itself} {
proc tproc {} {
proc tproc {} {
return 44
}
return 45
}
tproc
} 45
test proc-old-6.2 {procedure that deletes itself} {
proc tproc {} {
rename tproc {}
return 45
}
tproc
} 45
proc tproc code {
return -code $code abc
}
test proc-old-7.1 {return with special completion code} {
list [catch {tproc ok} msg] $msg
} {0 abc}
test proc-old-7.2 {return with special completion code} {
list [catch {tproc error} msg] $msg
} {1 abc}
test proc-old-7.3 {return with special completion code} {
list [catch {tproc return} msg] $msg
} {2 abc}
test proc-old-7.4 {return with special completion code} {
list [catch {tproc break} msg] $msg
} {3 abc}
test proc-old-7.5 {return with special completion code} {
list [catch {tproc continue} msg] $msg
} {4 abc}
test proc-old-7.6 {return with special completion code} {
list [catch {tproc -14} msg] $msg
} {-14 abc}
test proc-old-7.7 {return with special completion code} {
list [catch {tproc gorp} msg]
} {1}
test proc-old-7.8 {return with special completion code} {
list [catch {tproc 10b} msg]
} {1}
test proc-old-7.9 {return with special completion code} {
proc tproc2 {} {
tproc return
}
list [catch tproc2 msg] $msg
} {0 abc}
test proc-old-7.10 {return with special completion code} {
proc tproc2 {} {
return -code error
}
list [catch tproc2 msg] $msg
} {1 {}}
test proc-old-8.1 {unset and undefined local arrays} {
proc t1 {} {
foreach v {xxx, yyy} {
catch {unset $v}
}
set yyy(foo) bar
}
t1
} bar
test proc-old-9.1 {empty command name} {
catch {rename {} ""}
proc t1 {args} {
return
}
set v [t1]
catch {$v}
} 1
test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
proc t1 x {
set y 20
rename expr expr.old
rename expr.old expr
if $x then {t1 0} ;# recursive call after foo's code is invalidated
return 20
}
t1 1
} 20
# cleanup
catch {rename t1 ""}
catch {rename foo ""}
testreport

56
debuggers/openocd/jimtcl/tests/procref.test Normal file
View File

@ -0,0 +1,56 @@
# Tests auto-upref with the "&name" syntax
source [file dirname [info script]]/testing.tcl
needs constraint jim
proc a1 {&b c} {
append b b
append c c
}
proc a2 {&b {dummy 3} &c} {
append b b
append c c
}
proc a3 {&b(c)} {
append b(c) b_c
}
# This is treated as a normal var "&b"
proc a4 {{&b x}} {
append &b B
}
set B 1
set C 1
test procref-1.1 {Basic test} {
a1 B $C
set B
} {1b}
test procref-1.2 {Basic test} {
a1 B $C
set B
} {1bb}
test procref-1.3 {Unset var} -body {
a1 unsetB $C
} -returnCodes error -result {can't read "unsetB": no such variable}
test procref-1.4 {Left and right args are refs} {
a2 B C
list $B $C
} {1bbb 1c}
test procref-1.5 {Invalid arg} -body {
a3 B
} -returnCodes error -result {bad variable name "b(c)": upvar won't create a scalar variable that looks like an array element}
test procref-1.6 {Default arg as ref} {
a4
} xB
testreport

112
debuggers/openocd/jimtcl/tests/regcount.test Normal file
View File

@ -0,0 +1,112 @@
source [file dirname [info script]]/testing.tcl
needs cmd regexp
testConstraint regexp_are [expr {[regexp {\d} 1]}]
needs constraint regexp_are
# Test regexp counted repetitions
set n 0
foreach {pat str exp} {
a+ bac a
a{1,} bac a
a* bac {{}}
a{0,} bac {{}}
aa+ bac {}
a{2,} bac {}
a{2,} bacaad aa
a{3,} bacaad {}
{a{2,}$} bacaad {}
{a{2,}$} bacaa aa
{a{2,}$} ba {}
{a{2,}$} aa aa
{a{0,0}b$} b b
{a{1,1}b$} b {}
{a{1,1}b$} cab ab
{a{2,2}b$} cab {}
{a{2,2}b$} cabaabx {}
{a{2,2}b$} cacaab aab
ca{2,4}b cacaab caab
ca{2,3}b cacaab caab
ca{2,3}b cacaaab caaab
c(a|b){2,3}d xcbad {cbad a}
c(a|b){2,3}d xcabbd {cabbd b}
c(a|b){2,3}d xcbaaad {}
a{4} baaaad aaaa
a{2,5} baaaad aaaa
a{1,3} baaaad aaa
a{1,2} baaaad aa
a{3,4} baaaad aaaa
a{5,6} baaaad {}
a{4}? baaaad aaaa
a{2,5}? baaaad aa
a{1,3}? baaaad a
a{1,2}? baaaad a
a{3,4}? baaaad aaa
a{5,6}? baaaad {}
{\d{1,3}} 239 239
(aa|bb)?c xabbaac {aac aa}
(a|y)+ bac {a a}
(a|y){1,} bac {a a}
(a|y)* bac {{} {}}
(a|y){0,} bac {{} {}}
(a|y)a+ bac {}
(a|y){2,} bac {}
(a|y){2,} bacaad {aa a}
(a|y){3,} bacaad {}
{(a|y){2,}$} bacaad {}
{(a|y){2,}$} bacaa {aa a}
{(a|y){2,}$} ba {}
{(a|y){2,}$} aa {aa a}
{(a|y){0,0}b$} b {b {}}
{(a|y){1,1}b$} b {}
{(a|y){1,1}b$} cab {ab a}
{(a|y){2,2}b$} cab {}
{(a|y){2,2}b$} cabaabx {}
{(a|y){2,2}b$} cacaab {aab a}
c(a|y){2,4}b cacaab {caab a}
c(a|y){2,3}b cacaab {caab a}
c(a|y){2,3}b cacaaab {caaab a}
c((a|y)|b){2,3}d xcbad {cbad a a}
####c((a|y)|b){2,3}d xcabbd {cabbd b {}}
c((a|y)|b){2,3}d xcbaaad {}
(a|y){4} baaaad {aaaa a}
(a|y){2,5} baaaad {aaaa a}
(a|y){1,3} baaaad {aaa a}
(a|y){1,2} baaaad {aa a}
(a|y){3,4} baaaad {aaaa a}
(a|y){5,6} baaaad {}
(a|y){4}? baaaad {aaaa a}
(a|y){2,5}? baaaad {aa a}
(a|y){1,3}? baaaad {a a}
(a|y){1,2}? baaaad {a a}
(a|y){3,4}? baaaad {aaa a}
(a|y){5,6}? baaaad {}
{[[:alpha:]]+} _bcd56_ef bcd
{[[:alnum:]]+} _bcd56_ef bcd56
{[[:space:]]+} "_bc \t\r\n\f\v_" "{ \t\r\n\f\v}"
{[\x41-\x43]+} "_ABCD_" ABC
{\m.+\M} "#A test#" "{A test}"
{\m.+?\M} "#A test#" "A"
{\m\M} "a" ""
{ab*c} xnbbmbbbc {}
{.^xxx} yyy {}
{\mb} " abc " ""
####((a*)*b)*b aaaaaaaaaaaaaaaaaaaaaaaaab {b {} {}}
####(a*)* aab {aa {}}
{^([^:=]*)(:)?(=)?$} version {version version {} {}}
} {
if {[string match #* $pat]} {
continue
}
#puts \t[list $pat $str [regexp -inline -- $pat $str]]
test regcount-1.[incr n] "Test: regexp $pat $str" [list regexp -inline -- $pat $str] $exp
}
test regcount-2.1 "regexp counts cleared" {
set re "((a|b){1,2}(c{2,3}))"
regexp -inline $re xabcccce
regexp -inline $re xabcccce
} {abccc abccc b ccc}
testreport

679
debuggers/openocd/jimtcl/tests/regexp.test Normal file
View File

@ -0,0 +1,679 @@
# Commands covered: regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: regexp.test,v 1.30.2.1 2008/08/21 23:19:06 hobbs Exp $
source [file dirname [info script]]/testing.tcl
needs cmd regexp
catch {unset foo}
test regexp-1.1 {basic regexp operation} {
regexp ab*c abbbc
} 1
test regexp-1.2 {basic regexp operation} {
regexp ab*c ac
} 1
test regexp-1.3 {basic regexp operation} {
regexp ab*c ab
} 0
test regexp-1.4 {basic regexp operation} {
regexp -- -gorp abc-gorpxxx
} 1
test regexp-1.5 {basic regexp operation} {
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
} 1
#test regexp-1.6 {basic regexp operation} {
# list [catch {regexp {} abc} msg] $msg
#} {0 1}
#test regexp-1.7 {regexp utf compliance} {
# # if not UTF-8 aware, result is "0 1"
# set foo "\u4e4eb q"
# regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
# list [string compare $foo $bar] [regexp 4 $bar]
#} {0 0}
test regexp-2.1 {getting substrings back from regexp} {
set foo {}
list [regexp ab*c abbbbc foo] $foo
} {1 abbbbc}
test regexp-2.2 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp a(b*)c abbbbc foo f2] $foo $f2
} {1 abbbbc bbbb}
test regexp-2.3 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
} {1 abbbbc bbbb}
test regexp-2.4 {getting substrings back from regexp} {
set foo {}
set f2 {}
set f3 {}
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
} {1 abbbbc bbbb c}
test regexp-2.5 {getting substrings back from regexp} {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {};
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
12223345556789999aabbb \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9 $fa $fb
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
test regexp-2.6 {getting substrings back from regexp} {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 a a {} {}}
test regexp-2.7 {getting substrings back from regexp} {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 ac a {} c}
test regexp-2.8 {getting substrings back from regexp} {
set match {}
list [regexp {^a*b} aaaab match] $match
} {1 aaaab}
test regexp-2.9 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp f\352te(b*)c f\352tebbbbc foo f2] $foo $f2
} [list 1 f\352tebbbbc bbbb]
test regexp-2.10 {getting substrings back from regexp} {
set foo {}
set f2 {}
list [regexp f\352te(b*)c eff\352tebbbbc foo f2] $foo $f2
} [list 1 f\352tebbbbc bbbb]
test regexp-3.1 {-indices option to regexp} {
set foo {}
list [regexp -indices ab*c abbbbc foo] $foo
} {1 {0 5}}
test regexp-3.2 {-indices option to regexp} {
set foo {}
set f2 {}
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
} {1 {0 5} {1 4}}
test regexp-3.3 {-indices option to regexp} {
set foo {}
set f2 {}
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
} {1 {0 5} {1 4}}
test regexp-3.4 {-indices option to regexp} {
set foo {}
set f2 {}
set f3 {}
list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
} {1 {0 5} {1 4} {5 5}}
test regexp-3.5 {-indices option to regexp} {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}
list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
12223345556789999 \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9
} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
test regexp-3.6 {getting substrings back from regexp} {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexp-3.7 {getting substrings back from regexp} {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexp-4.1 {-nocase option to regexp} {
regexp -nocase foo abcFOo
} 1
test regexp-4.2 {-nocase option to regexp} {
set f1 22
set f2 33
set f3 44
list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
} {1 aBbbxYXxxZ Bbb xYXxx}
test regexp-4.3 {-nocase option to regexp} {
regexp -nocase FOo abcFOo
} 1
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
test regexp-4.4 {case conversion in regexp} {
list [regexp -nocase $x $x foo] $foo
} "1 $x"
catch {unset x}
test regexp-5.1 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*a bbba
} 1
test regexp-5.2 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*b xxxb
} 1
test regexp-5.3 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*c yyyc
} 1
test regexp-5.4 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*d 1d
} 1
test regexp-5.5 {exercise cache of compiled expressions} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*e xe
} 1
test regexp-6.1 {regexp errors} jim {
list [catch {regexp a} msg] $msg
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexp-6.2 {regexp errors} jim {
list [catch {regexp -nocase a} msg] $msg
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexp-6.3 {regexp errors} jim {
list [catch {regexp -gorp a} msg] $msg
} {1 {bad switch "-gorp": must be --, -all, -indices, -inline, -line, -nocase, or -start}}
test regexp-6.4 {regexp errors} {
catch {regexp a( b} msg
} 1
#test regexp-6.5 {regexp errors} {
# list [catch {regexp a) b} msg] [string match *parentheses* $msg]
#} {1 1}
test regexp-6.6 {regexp errors} {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
} {0 1}
test regexp-6.7 {regexp errors} {
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
} {0 0}
test regexp-6.8 {regexp errors} jim {
catch {unset f1}
set f1 44
list [catch {regexp abc abc f1(f2)} msg] $msg
} {1 {can't set "f1(f2)": variable isn't array}}
test regexp-6.9 {regexp errors, -start bad int check} {
list [catch {regexp -start bogus {^$} {}} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-7.1 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
} {1 xax111aaa222xaa}
test regexp-7.2 {basic regsub operation} {
list [regsub aa+ aaaxaa &111 foo] $foo
} {1 aaa111xaa}
test regexp-7.3 {basic regsub operation} {
list [regsub aa+ xaxaaa 111& foo] $foo
} {1 xax111aaa}
test regexp-7.4 {basic regsub operation} {
list [regsub aa+ aaa 11&2&333 foo] $foo
} {1 11aaa2aaa333}
test regexp-7.5 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
} {1 xaxaaa2aaa333xaa}
test regexp-7.6 {basic regsub operation} {
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
} {1 xax1aaa22aaaxaa}
test regexp-7.7 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
} {1 xax1aa22aaxaa}
test regexp-7.8 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
} "1 {xax1\\aa22aaxaa}"
test regexp-7.9 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
} "1 {xax1\\122aaxaa}"
test regexp-7.10 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
} "1 {xax1\\aaaaaxaa}"
test regexp-7.11 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
} {1 xax1&aaxaa}
test regexp-7.12 {basic regsub operation} {
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
} {1 xaxaaaaaaaaaaaaaaxaa}
test regexp-7.13 {basic regsub operation} {
set foo xxx
list [regsub abc xyz 111 foo] $foo
} {0 xyz}
test regexp-7.14 {basic regsub operation} {
set foo xxx
list [regsub ^ xyz "111 " foo] $foo
} {1 {111 xyz}}
test regexp-7.15 {basic regsub operation} {
set foo xxx
list [regsub -- -foo abc-foodef "111 " foo] $foo
} {1 {abc111 def}}
test regexp-7.16 {basic regsub operation} {
set foo xxx
list [regsub x "" y foo] $foo
} {0 {}}
#test regexp-7.17 {regsub utf compliance} {
# # if not UTF-8 aware, result is "0 1"
# set foo "xyz555ijka\u4e4ebpqr"
# regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
# list [string compare $foo $bar] [regexp 4 $bar]
#} {0 0}
test regexp-8.1 {case conversion in regsub} {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
} {1 xaAAaAAay}
test regexp-8.2 {case conversion in regsub} {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
} {1 xaAAaAAay}
test regexp-8.3 {case conversion in regsub} {
set foo 123
list [regsub a(a+) xaAAaAAay & foo] $foo
} {0 xaAAaAAay}
test regexp-8.4 {case conversion in regsub} {
set foo 123
list [regsub -nocase a CaDE b foo] $foo
} {1 CbDE}
test regexp-8.5 {case conversion in regsub} {
set foo 123
list [regsub -nocase XYZ CxYzD b foo] $foo
} {1 CbD}
test regexp-8.6 {case conversion in regsub} {
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
set foo 123
list [regsub -nocase $x $x b foo] $foo
} {1 b}
test regexp-9.1 {-all option to regsub} {
set foo 86
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
} {4 a|xxx|b|xx|c|x|d|x|}
test regexp-9.2 {-all option to regsub} {
set foo 86
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
} {4 a|XxX|b|xx|c|X|d|x|}
test regexp-9.3 {-all option to regsub} {
set foo 86
list [regsub x+ axxxbxxcxdx |&| foo] $foo
} {1 a|xxx|bxxcxdx}
test regexp-9.4 {-all option to regsub} {
set foo 86
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
} {0 axxxbxxcxdx}
test regexp-9.5 {-all option to regsub} {
set foo xxx
list [regsub -all node "node node more" yy foo] $foo
} {2 {yy yy more}}
test regexp-9.6 {-all option to regsub} {
set foo xxx
list [regsub -all ^ xxx 123 foo] $foo
} {1 123xxx}
test regexp-10.2 {newline sensitivity in regsub} {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
} "1 {dabc\n123\n}"
test regexp-10.3 {newline sensitivity in regsub} {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
} "1 {dabc\n123\nxb}"
#test regexp-10.4 {partial newline sensitivity in regsub} {
# set foo xxx
# list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
#} "1 {da\n123}"
#test regexp-10.5 {inverse partial newline sensitivity in regsub} {
# set foo xxx
# list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
#} "1 {da\nb123\nxb}"
test regexp-11.1 {regsub errors} jim {
list [catch {regsub a b} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} jim {
list [catch {regsub -nocase a b} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} jim {
list [catch {regsub -nocase -all a b} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} jim {
list [catch {regsub a b c d e f} msg] $msg
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} jim {
list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad switch "-gorp": must be --, -all, -line, -nocase, or -start}}
test regexp-11.6 {regsub errors} {
catch {regsub -nocase a( b c d} msg
} 1
test regexp-11.7 {regsub errors} jim {
catch {unset f1}
set f1 44
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
} {1 {can't set "f1(f2)": variable isn't array}}
test regexp-11.8 {regsub errors, -start bad int check} {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexp-11.9 {regsub without final variable name returns value} {
regsub b abaca X
} {aXaca}
test regexp-11.10 {regsub without final variable name returns value} {
regsub -all a abaca X
} {XbXcX}
test regexp-11.11 {regsub without final variable name returns value} {
regsub b(\[^d\]*)d abcdeabcfde {,&,\1,}
} {a,bcd,c,eabcfde}
test regexp-11.12 {regsub without final variable name returns value} {
regsub -all b(\[^d\]*)d abcdeabcfde {,&,\1,}
} {a,bcd,c,ea,bcfd,cf,e}
# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z
} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z}
test regexp-13.1 {regsub of a very large string} {
# This test is designed to stress the memory subsystem in order
# to catch Bug #933. It only fails if the Tcl memory allocator
# is in use.
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
set filedata [string repeat $line 200]
for {set i 1} {$i<10} {incr i} {
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
}
set x done
} {done}
test regexp-14.1 {CompileRegexp: regexp cache} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp $x bbba
} 1
test regexp-14.2 {CompileRegexp: regexp cache, different flags} {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
} 1
#test regexp-15.1 {regexp -start} {
# catch {unset x}
# list [regexp -start -10 {\d} 1abc2de3 x] $x
#} {1 1}
#test regexp-15.2 {regexp -start} {
# catch {unset x}
# list [regexp -start 2 {\d} 1abc2de3 x] $x
#} {1 2}
#test regexp-15.3 {regexp -start} {
# catch {unset x}
# list [regexp -start 4 {\d} 1abc2de3 x] $x
#} {1 2}
#test regexp-15.4 {regexp -start} {
# catch {unset x}
# list [regexp -start 5 {\d} 1abc2de3 x] $x
#} {1 3}
test regexp-15.5 {regexp -start, over end of string} {
catch {unset x}
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} {
list [regexp -start 2 {^$} {}]
} {0}
test regexp-15.7 {regexp -start, double option} {
regexp -start 2 -start 0 a abc
} 1
test regexp-15.8 {regexp -start, double option} {
regexp -start 0 -start 2 a abc
} 0
#test regexp-15.9 {regexp -start, end relative index} {
# catch {unset x}
# list [regexp -start end {\d} 1abc2de3 x] [info exists x]
#} {0 0}
#test regexp-15.10 {regexp -start, end relative index} {
# catch {unset x}
# list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
#} {1 1 3}
#
#test regexp-16.1 {regsub -start} {
# catch {unset x}
# list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
#} {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} {
catch {unset x}
list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
#test regexp-16.4 {regsub -start, \A behavior} {
# set out {}
# lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
# lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
#} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexp-16.5 {regsub -start, double option} {
list [regsub -start 2 -start 0 a abc c x] $x
} {1 cbc}
test regexp-16.6 {regsub -start, double option} {
list [regsub -start 0 -start 2 a abc c x] $x
} {0 abc}
test regexp-16.7 {regexp -start, end relative index} {
list [regsub -start end a aaa b x] $x
} {0 aaa}
test regexp-16.8 {regexp -start, end relative index} {
list [regsub -start end-1 a aaa b x] $x
} {1 aab}
test regexp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
test regexp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
#test regexp-17.4 {regexp -inline} {
# regexp -inline {\w(\d+)\w} " hello 23 there456def "
#} {e456d 456}
#test regexp-17.5 {regexp -inline no matches} {
# regexp -inline {\w(\d+)\w} ""
#} {}
test regexp-17.6 {regexp -inline no matches} {
regexp -inline hello goodbye
} {}
test regexp-17.7 {regexp -inline, no matchvars allowed} {
list [catch {regexp -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexp-18.1 {regexp -all} {
regexp -all b bbbbb
} {5}
test regexp-18.2 {regexp -all} {
regexp -all b abababbabaaaaaaaaaab
} {6}
test regexp-18.3 {regexp -all -inline} {
regexp -all -inline b abababbabaaaaaaaaaab
} {b b b b b b}
#test regexp-18.4 {regexp -all -inline} {
# regexp -all -inline {\w(\w)} abcdefg
#} {ab b cd d ef f}
#test regexp-18.5 {regexp -all -inline} {
# regexp -all -inline {\w(\w)$} abcdefg
#} {fg g}
#test regexp-18.6 {regexp -all -inline} {
# regexp -all -inline {\d+} 10:20:30:40
#} {10 20 30 40}
test regexp-18.7 {regexp -all -inline} {
list [catch {regexp -all -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexp-18.8 {regexp -all} {
# This should not cause an infinite loop
regexp -all -inline {a*} a
} {a}
test regexp-18.9 {regexp -all} {
# Yes, the expected result is {a {}}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; this is past the end of the string, so stop.
regexp -all -inline {a*} ab
} {a {}}
test regexp-18.10 {regexp -all} {
# Yes, the expected result is {a {} a}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; a* matches the "a" there then stops.
# Go to index 3; this is past the end of the string, so stop.
regexp -all -inline {a*} aba
} {a {} a}
test regexp-18.11 {regexp -all} {
regexp -all -inline {^a} aaaa
} {a}
test regexp-18.12 {regexp -all -inline -indices} {
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
test regexp-19.1 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
list $result [string length $result]
} "\0a\0hel\0a\0lo\0a\0 14"
#test regexp-20.1 {regsub shared object shimmering} {
# # Bug #461322
# set a abcdefghijklmnopqurstuvwxyz
# set b $a
# set c abcdefghijklmnopqurstuvwxyz0123456789
# regsub $a $c $b d
# list $d [string length $d] [string bytelength $d]
#} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
#test regexp-20.2 {regsub shared object shimmering with -about} {
# eval regexp -about abc
#} {0 {}}
test regexp-21.1 {regsub works with empty string} {
regsub -- ^ {} foo
} {foo}
test regexp-21.2 {regsub works with empty string} {
regsub -- \$ {} foo
} {foo}
test regexp-21.3 {regsub works with empty string offset} {
regsub -start 0 -- ^ {} foo
} {foo}
test regexp-21.4 {regsub works with empty string offset} {
regsub -start 0 -- \$ {} foo
} {foo}
test regexp-21.5 {regsub works with empty string offset} {
regsub -start 3 -- \$ {123} foo
} {123foo}
test regexp-21.6 {regexp works with empty string} {
regexp -- ^ {}
} {1}
test regexp-21.7 {regexp works with empty string} {
regexp -start 0 -- ^ {}
} {1}
test regexp-21.8 {regexp works with empty string offset} {
regexp -start 3 -- ^ {123}
} {0}
test regexp-21.9 {regexp works with empty string offset} {
regexp -start 3 -- \$ {123}
} {1}
#test regexp-21.10 {multiple matches handle newlines} {
# regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
#} "foo\nfoo\nfoo\n"
test regexp-21.11 {multiple matches handle newlines} {
regsub -all -line -- ^ "a\nb\nc" \#
} "\#a\n\#b\n\#c"
test regexp-21.12 {multiple matches handle newlines} {
regsub -all -line -- ^ "\n\n" \#
} "\#\n\#\n\#"
test regexp-21.13 {multiple matches handle newlines} {
regexp -all -inline -indices -line -- ^ "a\nb\nc"
} {{0 -1} {2 1} {4 3}}
test regexp-21.14 {Literal newline in pattern} {
regexp -all -inline "\n(\[ \t\]+)" "\n\t\t# This is a test"
} "{\n\t\t} {\t\t}"
test regexp-22.1 {effect of caching} jim {
set filedata {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
# Note: use 2 REs because often libc will cache a single regcomp() result
# t1 should be faster because the compiled re can be cached.
set re1 "END_TABLE"
set re2 "BEGIN_TABLE"
set t1 [time {
regexp -inline -all $re1 $filedata
regexp -inline -all $re2 $filedata
} 10000]
# t2 should be slower since the re's need to be recompiled every time
set t2 [time {
set re1 END
append re1 _TABLE
regexp -inline -all $re1 $filedata
set re2 BEGIN
append re2 _TABLE
regexp -inline -all $re2 $filedata
} 10000]
set t1 [lindex $t1 0]
set t2 [lindex $t2 0]
# If these two times are within 20% of each other, caching isn't working
expr {$t2 * 1.0 / $t1 < 1.2 && $t1 * 1.0 / $t2 < 1.2}
} {0}
testreport

917
debuggers/openocd/jimtcl/tests/regexp2.test Normal file
View File

@ -0,0 +1,917 @@
# Commands covered: regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
source [file dirname [info script]]/testing.tcl
needs cmd regexp
testConstraint regexp_are [regexp {\d} 1]
needs constraint regexp_are
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
proc testProc {} $script
set status [catch {
testProc
} result]
rename testProc {}
return $result
#return [list $status $result]
}
catch {unset foo}
test regexpComp-1.1 {basic regexp operation} {
evalInProc {
regexp ab*c abbbc
}
} 1
test regexpComp-1.2 {basic regexp operation} {
evalInProc {
regexp ab*c ac
}
} 1
test regexpComp-1.3 {basic regexp operation} {
evalInProc {
regexp ab*c ab
}
} 0
test regexpComp-1.4 {basic regexp operation} {
evalInProc {
regexp -- -gorp abc-gorpxxx
}
} 1
test regexpComp-1.5 {basic regexp operation} {
evalInProc {
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
}
} 1
test regexpComp-1.6 {basic regexp operation} {
list [catch {regexp {} abc} msg] $msg
} {0 1}
test regexpComp-1.7 {regexp utf compliance} {
# if not UTF-8 aware, result is "0 1"
evalInProc {
set foo "\u4e4eb q"
regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
test regexpComp-2.1 {getting substrings back from regexp} {
evalInProc {
set foo {}
list [regexp ab*c abbbbc foo] $foo
}
} {1 abbbbc}
test regexpComp-2.2 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp a(b*)c abbbbc foo f2] $foo $f2
}
} {1 abbbbc bbbb}
test regexpComp-2.3 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
}
} {1 abbbbc bbbb}
test regexpComp-2.4 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
set f3 {}
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
}
} {1 abbbbc bbbb c}
test regexpComp-2.5 {getting substrings back from regexp} {
evalInProc {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {};
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
12223345556789999aabbb \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9 $fa $fb
}
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
test regexpComp-2.6 {getting substrings back from regexp} {
evalInProc {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 a a {} {}}
test regexpComp-2.7 {getting substrings back from regexp} {
evalInProc {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 ac a {} c}
test regexpComp-2.8 {getting substrings back from regexp} {
evalInProc {
set match {}
list [regexp {^a*b} aaaab match] $match
}
} {1 aaaab}
test regexpComp-3.1 {-indices option to regexp} {
evalInProc {
set foo {}
list [regexp -indices ab*c abbbbc foo] $foo
}
} {1 {0 5}}
test regexpComp-3.2 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
}
} {1 {0 5} {1 4}}
test regexpComp-3.3 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
}
} {1 {0 5} {1 4}}
test regexpComp-3.4 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
set f3 {}
list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
}
} {1 {0 5} {1 4} {5 5}}
test regexpComp-3.5 {-indices option to regexp} {
evalInProc {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}
list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
12223345556789999 \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9
}
} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
test regexpComp-3.6 {getting substrings back from regexp} {
evalInProc {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexpComp-3.7 {getting substrings back from regexp} {
evalInProc {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexpComp-4.1 {-nocase option to regexp} {
evalInProc {
regexp -nocase foo abcFOo
}
} 1
test regexpComp-4.2 {-nocase option to regexp} {
evalInProc {
set f1 22
set f2 33
set f3 44
list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
}
} {1 aBbbxYXxxZ Bbb xYXxx}
test regexpComp-4.3 {-nocase option to regexp} {
evalInProc {
regexp -nocase FOo abcFOo
}
} 1
set ::x abcdefghijklmnopqrstuvwxyz1234567890
set ::x $x$x$x$x$x$x$x$x$x$x$x$x
test regexpComp-4.4 {case conversion in regexp} {
evalInProc {
list [regexp -nocase $::x $::x foo] $foo
}
} "1 $x"
catch {unset ::x}
test regexpComp-5.1 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*a bbba
}
} 1
test regexpComp-5.2 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*b xxxb
}
} 1
test regexpComp-5.3 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*c yyyc
}
} 1
test regexpComp-5.4 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*d 1d
}
} 1
test regexpComp-5.5 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*e xe
}
} 1
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.6 {regexp errors} {
evalInProc {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
}
} {0 1}
test regexpComp-6.7 {regexp errors} {
evalInProc {
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
}
} {0 0}
test regexpComp-6.8 {regexp errors} {
evalInProc {
catch {unset f1}
set f1 44
catch {regexp abc abc f1(f2)} msg
}
} {1}
test regexpComp-6.9 {regexp errors, -start bad int check} {
evalInProc {
list [catch {regexp -start bogus {^$} {}} msg] $msg
}
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
test regexpComp-7.1 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
}
} {1 xax111aaa222xaa}
test regexpComp-7.2 {basic regsub operation} {
evalInProc {
list [regsub aa+ aaaxaa &111 foo] $foo
}
} {1 aaa111xaa}
test regexpComp-7.3 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaa 111& foo] $foo
}
} {1 xax111aaa}
test regexpComp-7.4 {basic regsub operation} {
evalInProc {
list [regsub aa+ aaa 11&2&333 foo] $foo
}
} {1 11aaa2aaa333}
test regexpComp-7.5 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
}
} {1 xaxaaa2aaa333xaa}
test regexpComp-7.6 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
}
} {1 xax1aaa22aaaxaa}
test regexpComp-7.7 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
}
} {1 xax1aa22aaxaa}
test regexpComp-7.8 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
}
} "1 {xax1\\aa22aaxaa}"
test regexpComp-7.9 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
}
} "1 {xax1\\122aaxaa}"
test regexpComp-7.10 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
}
} "1 {xax1\\aaaaaxaa}"
test regexpComp-7.11 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
}
} {1 xax1&aaxaa}
test regexpComp-7.12 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
}
} {1 xaxaaaaaaaaaaaaaaxaa}
test regexpComp-7.13 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub abc xyz 111 foo] $foo
}
} {0 xyz}
test regexpComp-7.14 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub ^ xyz "111 " foo] $foo
}
} {1 {111 xyz}}
test regexpComp-7.15 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub -- -foo abc-foodef "111 " foo] $foo
}
} {1 {abc111 def}}
test regexpComp-7.16 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub x "" y foo] $foo
}
} {0 {}}
test regexpComp-7.17 {regsub utf compliance} {
evalInProc {
# if not UTF-8 aware, result is "0 1"
set foo "xyz555ijka\u4e4ebpqr"
regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
test regexpComp-7.18 {regsub utf8 in char range} utf8 {
regsub {[\u4e4ex]b} xyza\u4e4ebijka\u4e4ebpqr 555
} xyza555ijka\u4e4ebpqr
test regexpComp-7.19 {regsub utf8 in complemented char range} utf8 {
regsub -all {[^x\u4e4e]b} xyza\u4e4ebizbjxbka\u4e4fbpqr 555
} xyza\u4e4ebi555jxbka555pqr
test regexpComp-8.1 {case conversion in regsub} {
evalInProc {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
}
} {1 xaAAaAAay}
test regexpComp-8.2 {case conversion in regsub} {
evalInProc {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
}
} {1 xaAAaAAay}
test regexpComp-8.3 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub a(a+) xaAAaAAay & foo] $foo
}
} {0 xaAAaAAay}
test regexpComp-8.4 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub -nocase a CaDE b foo] $foo
}
} {1 CbDE}
test regexpComp-8.5 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub -nocase XYZ CxYzD b foo] $foo
}
} {1 CbD}
test regexpComp-8.6 {case conversion in regsub} {
evalInProc {
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
set foo 123
list [regsub -nocase $x $x b foo] $foo
}
} {1 b}
test regexpComp-9.1 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
}
} {4 a|xxx|b|xx|c|x|d|x|}
test regexpComp-9.2 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
}
} {4 a|XxX|b|xx|c|X|d|x|}
test regexpComp-9.3 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub x+ axxxbxxcxdx |&| foo] $foo
}
} {1 a|xxx|bxxcxdx}
test regexpComp-9.4 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
}
} {0 axxxbxxcxdx}
test regexpComp-9.5 {-all option to regsub} {
evalInProc {
set foo xxx
list [regsub -all node "node node more" yy foo] $foo
}
} {2 {yy yy more}}
test regexpComp-9.6 {-all option to regsub} {
evalInProc {
set foo xxx
list [regsub -all ^ xxx 123 foo] $foo
}
} {1 123xxx}
#test regexpComp-10.1 {expanded syntax in regsub} {
# evalInProc {
# set foo xxx
# list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
# }
#} {1 defc}
test regexpComp-10.2 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
}
} "1 {dabc\n123\n}"
test regexpComp-10.3 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
}
} "1 {dabc\n123\nxb}"
#test regexpComp-10.4 {partial newline sensitivity in regsub} {
# evalInProc {
# set foo xxx
# list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
# }
#} "1 {da\n123}"
#test regexpComp-10.5 {inverse partial newline sensitivity in regsub} {
# evalInProc {
# set foo xxx
# list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
# }
#} "1 {da\nb123\nxb}"
#test regexpComp-11.1 {regsub errors} {
# evalInProc {
# list [catch {regsub a b} msg] $msg
# }
#} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
#test regexpComp-11.2 {regsub errors} {
# evalInProc {
# list [catch {regsub -nocase a b} msg] $msg
# }
#} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
#test regexpComp-11.3 {regsub errors} {
# evalInProc {
# list [catch {regsub -nocase -all a b} msg] $msg
# }
#} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
#test regexpComp-11.4 {regsub errors} {
# evalInProc {
# list [catch {regsub a b c d e f} msg] $msg
# }
#} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
#test regexpComp-11.5 {regsub errors} {
# evalInProc {
# list [catch {regsub -gorp a b c} msg] $msg
# }
#} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
#test regexpComp-11.6 {regsub errors} {
# evalInProc {
# list [catch {regsub -nocase a( b c d} msg] $msg
# }
#} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
evalInProc {
catch {unset f1}
set f1 44
catch {regsub -nocase aaa aaa xxx f1(f2)} msg
}
} {1}
test regexpComp-11.8 {regsub errors, -start bad int check} {
evalInProc {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
}
} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {
evalInProc {
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z
}
} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z}
test regexpComp-13.1 {regsub of a very large string} {
# This test is designed to stress the memory subsystem in order
# to catch Bug #933. It only fails if the Tcl memory allocator
# is in use.
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
set filedata [string repeat $line 200]
for {set i 1} {$i<10} {incr i} {
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
}
set x done
} {done}
test regexpComp-14.1 {CompileRegexp: regexp cache} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp $x bbba
}
} 1
test regexpComp-14.2 {CompileRegexp: regexp cache, different flags} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
}
} 1
test regexpComp-15.1 {regexp -start} {
catch {unset x}
list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexpComp-15.2 {regexp -start} {
catch {unset x}
list [regexp -start 2 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.3 {regexp -start} {
catch {unset x}
list [regexp -start 4 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.4 {regexp -start} {
catch {unset x}
list [regexp -start 5 {\d} 1abc2de3 x] $x
} {1 3}
test regexpComp-15.5 {regexp -start, over end of string} {
catch {unset x}
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
list [regexp -start 2 {^$} {}]
} {0}
test regexpComp-16.1 {regsub -start} {
catch {unset x}
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexpComp-16.2 {regsub -start} {
catch {unset x}
list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
#test regexpComp-16.4 {regsub -start, \A behavior} {
# set out {}
# lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
# lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
#} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexpComp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexpComp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
test regexpComp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
test regexpComp-17.4 {regexp -inline} {
regexp -inline {\w(\d+)\w} " hello 23 there456def "
} {e456d 456}
test regexpComp-17.5 {regexp -inline no matches} {
regexp -inline {\w(\d+)\w} ""
} {}
test regexpComp-17.6 {regexp -inline no matches} {
regexp -inline hello goodbye
} {}
test regexpComp-17.7 {regexp -inline, no matchvars allowed} {
list [catch {regexp -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexpComp-18.1 {regexp -all} {
regexp -all b bbbbb
} {5}
test regexpComp-18.2 {regexp -all} {
regexp -all b abababbabaaaaaaaaaab
} {6}
test regexpComp-18.3 {regexp -all -inline} {
regexp -all -inline b abababbabaaaaaaaaaab
} {b b b b b b}
test regexpComp-18.4 {regexp -all -inline} {
regexp -all -inline {\w(\w)} abcdefg
} {ab b cd d ef f}
test regexpComp-18.5 {regexp -all -inline} {
regexp -all -inline {\w(\w)$} abcdefg
} {fg g}
test regexpComp-18.6 {regexp -all -inline} {
regexp -all -inline {\d+} 10:20:30:40
} {10 20 30 40}
test regexpComp-18.7 {regexp -all -inline} {
list [catch {regexp -all -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexpComp-18.8 {regexp -all} {
# This should not cause an infinite loop
regexp -all -inline {a*} a
} {a}
test regexpComp-18.9 {regexp -all} {
# Yes, the expected result is {a {}}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; this is past the end of the string, so stop.
regexp -all -inline {a*} ab
} {a {}}
test regexpComp-18.10 {regexp -all} {
# Yes, the expected result is {a {} a}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; a* matches the "a" there then stops.
# Go to index 3; this is past the end of the string, so stop.
regexp -all -inline {a*} aba
} {a {} a}
test regexpComp-18.11 {regexp -all} {
evalInProc {
regexp -all -inline {^a} aaaa
}
} {a}
test regexpComp-18.12 {regexp -all -inline -indices} {
evalInProc {
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
}
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
test regexpComp-19.1 {regsub null replacement} {
evalInProc {
regsub -all {@} {@hel@lo@} "\0a\0" result
list $result [string length $result]
}
} "\0a\0hel\0a\0lo\0a\0 14"
test regexpComp-20.1 {regsub shared object shimmering} {
evalInProc {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
}
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
#test regexpComp-20.2 {regsub shared object shimmering with -about} {
# evalInProc {
# eval regexp -about abc
# }
#} {0 {}}
test regexpComp-21.1 {regexp command compiling tests} {
evalInProc {
regexp foo bar
}
} 0
test regexpComp-21.2 {regexp command compiling tests} {
evalInProc {
regexp {^foo$} dogfood
}
} 0
test regexpComp-21.3 {regexp command compiling tests} {
evalInProc {
set a foo
regexp {^foo$} $a
}
} 1
test regexpComp-21.4 {regexp command compiling tests} {
evalInProc {
regexp foo dogfood
}
} 1
test regexpComp-21.5 {regexp command compiling tests} {
evalInProc {
regexp -nocase FOO dogfod
}
} 0
test regexpComp-21.6 {regexp command compiling tests} {
evalInProc {
regexp -n foo dogfoOd
}
} 1
test regexpComp-21.7 {regexp command compiling tests} {
evalInProc {
regexp -no -- FoO dogfood
}
} 1
test regexpComp-21.8 {regexp command compiling tests} {
evalInProc {
regexp -- foo dogfod
}
} 0
test regexpComp-21.9 {regexp command compiling tests} {
evalInProc {
list [catch {regexp -- -nocase foo dogfod} msg] $msg
}
} {0 0}
test regexpComp-21.10 {regexp command compiling tests} {
evalInProc {
list [regsub -all "" foo bar str] $str
}
} {3 barfbarobaro}
# This useless expression fails. Jim returns "bar"
#test regexpComp-21.11 {regexp command compiling tests} {
# evalInProc {
# list [regsub -all "" "" bar str] $str
# }
#} {0 {}}
# We can forgive the underlying regexp engine for not supporting this.
# Why not use this instead? "((^X)*|\$)"
#test regexpComp-22.0.1 {Bug 1810038} {
# evalInProc {
# regexp ($|^X)* {}
# }
#} 1
set i 0
foreach {str exp result} {
foo ^foo 1
foobar ^foobar$ 1
foobar bar$ 1
foobar ^$ 0
"" ^$ 1
anything $ 1
anything ^.*$ 1
anything ^.*a$ 0
anything ^.*a.*$ 1
anything ^.*.*$ 1
anything ^.*..*$ 1
anything ^.*b$ 0
anything ^a.*$ 1
} {
test regexpComp-22.[incr i] {regexp command compiling tests} \
[subst {evalInProc {set a "$str"; regexp {$exp} \$a}}] $result
}
set i 0
foreach {str exp result} {
foo ^foo 1
foobar ^foobar$ 1
foobar bar$ 1
foobar ^$ 0
"" ^$ 1
anything $ 1
anything ^.*$ 1
anything ^.*a$ 0
anything ^.*a.*$ 1
anything ^.*.*$ 1
anything ^.*..*$ 1
anything ^.*b$ 0
anything ^a.*$ 1
} {
test regexpComp-23.[incr i] {regexp command compiling tests INST_REGEXP} \
[list regexp $exp $str] $result
}
test regexpComp-24.1 {regexp command compiling tests} {
evalInProc {
set re foo
regexp -nocase $re bar
}
} 0
test regexpComp-24.2 {regexp command compiling tests} {
evalInProc {
set re {^foo$}
regexp $re dogfood
}
} 0
test regexpComp-24.3 {regexp command compiling tests} {
evalInProc {
set a foo
set re {^foo$}
regexp $re $a
}
} 1
test regexpComp-24.4 {regexp command compiling tests} {
evalInProc {
set re foo
regexp $re dogfood
}
} 1
test regexpComp-24.5 {regexp command compiling tests} {
evalInProc {
set re FOO
regexp -nocase $re dogfod
}
} 0
test regexpComp-24.6 {regexp command compiling tests} {
evalInProc {
set re foo
regexp -n $re dogfoOd
}
} 1
test regexpComp-24.7 {regexp command compiling tests} {
evalInProc {
set re FoO
regexp -no -- $re dogfood
}
} 1
test regexpComp-24.8 {regexp command compiling tests} {
evalInProc {
set re foo
regexp -- $re dogfod
}
} 0
test regexpComp-24.9 {regexp command compiling tests} {
evalInProc {
set re "("
list [catch {regexp -- $re dogfod} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-24.10 {regexp command compiling tests} {
# Bug 1902436 - last * escaped
evalInProc {
set text {this is *bold* !}
set re {\*bold\*}
regexp -- $re $text
}
} 1
test regexpComp-24.11 {regexp command compiling tests} {
# Bug 1902436 - last * escaped
evalInProc {
set text {this is *bold* !}
set re {\*bold\*.*!}
regexp -- $re $text
}
} 1
test regexp-25.1 {Repeat on escaped char} {
regexp {\x41\x42*} bc
} 0
test regexp-25.2 {Single braced count} {
regexp "a{4}" baaaad
} 1
testreport

55
debuggers/openocd/jimtcl/tests/regmin.test Normal file
View File

@ -0,0 +1,55 @@
source [file dirname [info script]]/testing.tcl
needs cmd regexp
testConstraint regexp_are [regexp {\d} 1]
needs constraint regexp_are
test regexpmin-1.1 {Minimal +} {
regexp -inline {x(a|b|c)+?c} xabcabc
} {xabc b}
test regexpmin-1.2 {Maximal +} {
regexp -inline {x(a|b|c)+c} xabcabc
} {xabcabc b}
test regexpmin-1.3 {Minimal *} {
regexp -inline {x(a|b)*?} xababcabc
} {x {}}
test regexpmin-1.4 {Maximal *} {
regexp -inline {x(a|b)*} xababcabc
} {xabab b}
test regexpmin-1.5 {Maximal ?} {
regexp -inline {x(a|b)?} xababcabc
} {xa a}
test regexpmin-1.6 {Minimal ?} {
regexp -inline {x(a|b)??} xababcabc
} {x {}}
test regexpmin-1.7 {Maximal html} {
regexp -inline {<(.+)>} <foo><bar><grill>
} {<foo><bar><grill> foo><bar><grill}
test regexpmin-1.8 {Minimal html} {
regexp -inline {<(.+?)>} <foo><bar><grill>
} {<foo> foo}
test regexpmin-2.1 {utf8 repeat} utf8 {
regexp -inline {a\u00df+} a\udf\udf\udf\udf\ub5z
} "a\udf\udf\udf\udf"
test regexpmin-2.2 {utf8 min repeat} utf8 {
regexp -inline {a\u00df+?} a\udf\udf\udf\udf\ub5z
} "a\udf"
test regexpmin-3.1 {non-capturing paren} {
regexp -inline {x(?:a|b)?} xababcabc
} {xa}
test regexpmin-3.2 {non-capturing paren} {
regexp -inline {x(?:a|b)?.*(b|c)} xababcabc
} {xababcabc c}
testreport

155
debuggers/openocd/jimtcl/tests/rename.test Normal file
View File

@ -0,0 +1,155 @@
# Commands covered: rename
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: rename.test,v 1.8.2.1 2001/09/12 20:34:59 dgp Exp $
source [file dirname [info script]]/testing.tcl
# Must eliminate the "unknown" command while the test is running,
# especially if the test is being run in a program with its
# own special-purpose unknown command.
catch {rename unknown unknown.old}
catch {rename r2 {}}
proc r1 {} {return "procedure r1"}
rename r1 r2
test rename-1.1 {simple renaming} {
r2
} {procedure r1}
test rename-1.2 {simple renaming} {
list [catch r1 msg] $msg
} {1 {invalid command name "r1"}}
rename r2 {}
test rename-1.3 {simple renaming} {
list [catch r2 msg] $msg
} {1 {invalid command name "r2"}}
# The test below is tricky because it renames a built-in command.
# It's possible that the test procedure uses this command, so must
# restore the command before calling test again.
rename list l.new
set a [catch list msg1]
set b [l.new a b c]
rename l.new list
set c [catch l.new msg2]
set d [list 111 222]
test rename-2.1 {renaming built-in command} {
list $a $msg1 $b $c $msg2 $d
} {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}}
test rename-3.1 {error conditions} {
list [catch {rename r1} msg] $msg
} {1 {wrong # args: should be "rename oldName newName"}}
test rename-3.2 {error conditions} {
list [catch {rename r1 r2 r3} msg] $msg
} {1 {wrong # args: should be "rename oldName newName"}}
test rename-3.3 {error conditions} {
proc r1 {} {}
proc r2 {} {}
list [catch {rename r1 r2} msg] $msg
} {1 {can't rename to "r2": command already exists}}
test rename-3.4 {error conditions} {
catch {rename r1 {}}
catch {rename r2 {}}
list [catch {rename r1 r2} msg] $msg
} {1 {can't rename "r1": command doesn't exist}}
test rename-3.5 {error conditions} {
catch {rename _non_existent_command {}}
list [catch {rename _non_existent_command {}} msg] $msg
} {1 {can't delete "_non_existent_command": command doesn't exist}}
catch {rename unknown {}}
catch {rename unknown.old unknown}
if {[info command testdel] == "testdel"} {
test rename-4.1 {reentrancy issues with command deletion and renaming} {
set x {}
testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]}
rename foo bar
lappend x |
rename bar {}
set x
} {| deleted {}}
test rename-4.2 {reentrancy issues with command deletion and renaming} {
set x {}
testdel {} foo {lappend x deleted; rename foo bar}
rename foo {}
set x
} {deleted}
test rename-4.3 {reentrancy issues with command deletion and renaming} {
set x {}
testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}}
rename foo {}
lappend x |
rename foo {}
set x
} {deleted | deleted2}
test rename-4.4 {reentrancy issues with command deletion and renaming} {
set x {}
testdel {} foo {lappend x deleted; rename foo bar}
rename foo {}
lappend x | [info command bar]
} {deleted | {}}
test rename-4.5 {reentrancy issues with command deletion and renaming} {
set env(value) before
interp create foo
testdel foo cmd {set env(value) deleted}
interp delete foo
set env(value)
} {deleted}
test rename-4.6 {reentrancy issues with command deletion and renaming} {
proc killx args {
interp delete foo
}
set env(value) before
interp create foo
foo alias killx killx
testdel foo cmd {set env(value) deleted; killx}
list [catch {foo eval {rename cmd {}}} msg] $msg $env(value)
} {0 {} deleted}
test rename-4.7 {reentrancy issues with command deletion and renaming} {
proc killx args {
interp delete foo
}
set env(value) before
interp create foo
foo alias killx killx
testdel foo cmd {set env(value) deleted; killx}
list [catch {interp delete foo} msg] $msg $env(value)
} {0 {} deleted}
if {[info exists env(value)]} {
unset env(value)
}
}
test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } {
proc x {} {
set a 123
set b [split a 2]
}
x
rename split split.old
proc split {} {puts "new split called!"}
catch {x} msg
} 1
if {[info commands split.old] != {}} {
catch {rename split {}}
catch {rename split.old split}
}
catch {rename x {}}
catch {rename killx {}}
testreport

1
debuggers/openocd/jimtcl/tests/return-break.tcl Normal file
View File

@ -0,0 +1 @@
return -code break result

50
debuggers/openocd/jimtcl/tests/return.test Normal file
View File

@ -0,0 +1,50 @@
source [file dirname [info script]]/testing.tcl
# return -code
test return-1.1 {return -code} {
set script "return -code 4 result"
list [catch {eval $script} msg] $msg
} {2 result}
test return-1.2 {source file with break} {
list [catch {source break.tcl} msg] $msg
} {3 {}}
test return-1.3 {source file with break} {
list [catch {source return-break.tcl} msg] $msg
} {3 result}
proc a {level code msg} {
return -level $level -code $code $msg
}
proc b {level code msg} {
a $level $code $msg
}
test return-2.1 {return -level 0} {
list [catch {a 0 20 text} msg] $msg
} {20 text}
test return-2.2 {return -level 1} {
list [catch {a 1 20 text} msg] $msg
} {20 text}
test return-2.3 {return -level 2} {
list [catch {a 2 20 text} msg] $msg
} {2 text}
test return-2.4 {return -level 0} {
list [catch {b 0 20 text} msg] $msg
} {20 text}
test return-2.5 {return -level 1} {
list [catch {b 1 20 text} msg] $msg
} {20 text}
test return-2.6 {return -level 2} {
list [catch {b 2 20 text} msg] $msg
} {20 text}
testreport

673
debuggers/openocd/jimtcl/tests/scan.test Normal file
View File

@ -0,0 +1,673 @@
# Commands covered: scan
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: scan.test,v 1.10.2.2 2002/02/07 01:54:04 hobbs Exp $
source [file dirname [info script]]/testing.tcl
needs cmd scan
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
list [scan \]foo {%[]f]} x] $x
} {1 \]f}
test scan-1.3 {BuildCharSet, CharInSet} {
list [scan abc-def {%[a-c]} x] $x
} {1 abc}
test scan-1.4 {BuildCharSet, CharInSet} {
list [scan abc-def {%[a-c]} x] $x
} {1 abc}
test scan-1.5 {BuildCharSet, CharInSet} {
list [scan -abc-def {%[-ac]} x] $x
} {1 -a}
test scan-1.6 {BuildCharSet, CharInSet} {
list [scan -abc-def {%[ac-]} x] $x
} {1 -a}
test scan-1.7 {BuildCharSet, CharInSet} {
list [scan abc-def {%[c-a]} x] $x
} {1 abc}
test scan-1.8 {BuildCharSet, CharInSet} {
list [scan def-abc {%[^c-a]} x] $x
} {1 def-}
test scan-1.9 {BuildCharSet, CharInSet no match} {
catch {unset x}
list [scan {= f} {= %[TF]} x] [info exists x]
} {0 0}
test scan-2.1 {ReleaseCharSet} {
list [scan abcde {%[abc]} x] $x
} {1 abc}
test scan-2.2 {ReleaseCharSet} {
list [scan abcde {%[a-c]} x] $x
} {1 abc}
test scan-3.1 {ValidateFormat} {
list [catch {scan {} {%d%1$d} x} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test scan-3.2 {ValidateFormat} {
list [catch {scan {} {%d%1$d} x} msg] $msg
} {1 {cannot mix "%" and "%n$" conversion specifiers}}
test scan-3.3 {ValidateFormat} {
list [catch {scan {} {%2$d%d} x} msg] $msg
} {1 {"%n$" argument index out of range}}
test scan-3.4 {ValidateFormat} {
# degenerate case, before changed from 8.2 to 8.3
list [catch {scan {} %d} msg] $msg
} {0 {}}
test scan-3.5 {ValidateFormat} {
list [catch {scan {} {%10c} a} msg] $msg
} {1 {field width may not be specified in %c conversion}}
test scan-3.6 {ValidateFormat} jim {
list [catch {scan {} {%*1$d} a} msg] $msg
} {1 {bad scan conversion character}}
test scan-3.7 {ValidateFormat} {
list [catch {scan {} {%1$d%1$d} a} msg] $msg
} {1 {variable is assigned by multiple "%n$" conversion specifiers}}
test scan-3.8 {ValidateFormat} {
list [catch {scan {} a x} msg] $msg
} {1 {variable is not assigned by any conversion specifiers}}
test scan-3.9 {ValidateFormat} {
list [catch {scan {} {%2$s} x y} msg] $msg
} {1 {variable is not assigned by any conversion specifiers}}
test scan-3.10 {ValidateFormat} {
list [catch {scan {} {%[a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-3.11 {ValidateFormat} {
list [catch {scan {} {%[^a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-3.12 {ValidateFormat} {
list [catch {scan {} {%[]a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-3.13 {ValidateFormat} {
list [catch {scan {} {%[^]a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-4.1 {Tcl_ScanObjCmd, argument checks} jim {
list [catch {scan} msg] $msg
} {1 {wrong # args: should be "scan string format ?varName varName ...?"}}
test scan-4.2 {Tcl_ScanObjCmd, argument checks} jim {
list [catch {scan string} msg] $msg
} {1 {wrong # args: should be "scan string format ?varName varName ...?"}}
test scan-4.3 {Tcl_ScanObjCmd, argument checks} {
# degenerate case, before changed from 8.2 to 8.3
list [catch {scan string format} msg] $msg
} {0 {}}
test scan-4.4 {Tcl_ScanObjCmd, whitespace} {
list [scan { abc def } {%s%s} x y] $x $y
} {2 abc def}
test scan-4.5 {Tcl_ScanObjCmd, whitespace} {
list [scan { abc def } { %s %s } x y] $x $y
} {2 abc def}
test scan-4.6 {Tcl_ScanObjCmd, whitespace} {
list [scan { abc def } { %s %s } x y] $x $y
} {2 abc def}
test scan-4.7 {Tcl_ScanObjCmd, literals} {
# degenerate case, before changed from 8.2 to 8.3
scan { abc def } { abc def }
} {}
test scan-4.8 {Tcl_ScanObjCmd, literals} {
set x {}
list [scan { abcg} { abc def %1s} x] $x
} {0 {}}
test scan-4.9 {Tcl_ScanObjCmd, literals} {
list [scan { abc%defghi} { abc %% def%n } x] $x
} {1 10}
test scan-4.10 {Tcl_ScanObjCmd, assignment suppression} {
list [scan { abc def } { %*c%s def } x] $x
} {1 bc}
test scan-4.11 {Tcl_ScanObjCmd, XPG3-style} {
list [scan { abc def } {%2$s %1$s} x y] $x $y
} {2 def abc}
test scan-4.12 {Tcl_ScanObjCmd, width specifiers} {
list [scan {abc123456789012} {%3s%3d%3f%3[0-9]%s} a b c d e] $a $b $c $d $e
} {5 abc 123 456.0 789 012}
test scan-4.13 {Tcl_ScanObjCmd, width specifiers} {
list [scan {abc123456789012} {%3s%3d%3f%3[0-9]%s} a b c d e] $a $b $c $d $e
} {5 abc 123 456.0 789 012}
test scan-4.14 {Tcl_ScanObjCmd, underflow} {
set x {}
list [scan {a} {a%d} x] $x
} {-1 {}}
test scan-4.15 {Tcl_ScanObjCmd, underflow} {
set x {}
list [scan {} {a%d} x] $x
} {-1 {}}
test scan-4.16 {Tcl_ScanObjCmd, underflow} {
set x {}
list [scan {ab} {a%d} x] $x
} {0 {}}
test scan-4.17 {Tcl_ScanObjCmd, underflow} {
set x {}
list [scan {a } {a%d} x] $x
} {-1 {}}
test scan-4.18 {Tcl_ScanObjCmd, skipping whitespace} {
list [scan { b} {%c%s} x y] $x $y
} {2 32 b}
test scan-4.19 {Tcl_ScanObjCmd, skipping whitespace} {
list [scan { b} {%[^b]%s} x y] $x $y
} {2 { } b}
test scan-4.20 {Tcl_ScanObjCmd, string scanning} {
list [scan {abc def} {%s} x] $x
} {1 abc}
test scan-4.21 {Tcl_ScanObjCmd, string scanning} {
list [scan {abc def} {%0s} x] $x
} {1 abc}
test scan-4.22 {Tcl_ScanObjCmd, string scanning} {
list [scan {abc def} {%2s} x] $x
} {1 ab}
test scan-4.23 {Tcl_ScanObjCmd, string scanning} {
list [scan {abc def} {%*s%n} x] $x
} {1 3}
test scan-4.24 {Tcl_ScanObjCmd, charset scanning} {
list [scan {abcdef} {%[a-c]} x] $x
} {1 abc}
test scan-4.25 {Tcl_ScanObjCmd, charset scanning} {
list [scan {abcdef} {%0[a-c]} x] $x
} {1 abc}
test scan-4.26 {Tcl_ScanObjCmd, charset scanning} {
list [scan {abcdef} {%2[a-c]} x] $x
} {1 ab}
test scan-4.27 {Tcl_ScanObjCmd, charset scanning} {
list [scan {abcdef} {%*[a-c]%n} x] $x
} {1 3}
test scan-4.28 {Tcl_ScanObjCmd, character scanning} {
list [scan {abcdef} {%c} x] $x
} {1 97}
test scan-4.29 {Tcl_ScanObjCmd, character scanning} {
list [scan {abcdef} {%*c%n} x] $x
} {1 1}
test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {1234567890a} {%3d} x] $x
} {1 123}
test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {1234567890a} {%d} x] $x
} {1 1234567890}
test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {01234567890a} {%d} x] $x
} {1 1234567890}
test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {+01234} {%d} x] $x
} {1 1234}
test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {-01234} {%d} x] $x
} {1 -1234}
test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {a01234} {%d} x] $x
} {0 {}}
test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} {
set x {}
list [scan {0x10} {%d} x] $x
} {1 0}
test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} {
set x {}
list [scan {012345678} {%o} x] $x
} {1 342391}
test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} {
set x {}
list [scan {+1238 -1239 123a} {%o%*s%o%*s%o} x y z] $x $y $z
} {3 83 -83 83}
test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} {
set x {}
list [scan {+1238 -123a 0123} {%x%x%x} x y z] $x $y $z
} {3 4664 -4666 291}
test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} {
# The behavior changed in 8.4a4/8.3.4cvs (6 Feb) to correctly
# return '1' for 0x1 scanned via %x, to comply with 8.0 and C scanf.
# Bug #495213
set x {}
list [scan {aBcDeF AbCdEf 0x1} {%x%x%x} x y z] $x $y $z
} {3 11259375 11259375 1}
test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} {
set x {}
list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z
} {3 15 2571 0}
test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} {
catch {unset x}
list [scan {xF} {%x} x] [info exists x]
} {0 0}
test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} {
set x {}
list [scan {10 010 0x10} {%i%i%i} x y z] $x $y $z
} {3 10 10 16}
test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} {
set x {}
list [scan {10 010 0X10} {%i%i%i} x y z] $x $y $z
} {3 10 10 16}
test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} {
set x {}
list [scan {+ } {%i} x] $x
} {0 {}}
#test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} {
# set x {}
# list [scan {+} {%i} x] $x
#} {-1 {}}
test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} {
set x {}
list [scan {0x} {%i%s} x y] $x $y
} {2 0 x}
test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} {
set x {}
list [scan {0X} {%i%s} x y] $x $y
} {2 0 X}
test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} {
set x {}
list [scan {123def} {%*i%s} x] $x
} {1 def}
test scan-4.48 {Tcl_ScanObjCmd, float scanning} {
list [scan {1 2 3} {%e %f %g} x y z] $x $y $z
} {3 1.0 2.0 3.0}
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.50 {Tcl_ScanObjCmd, float scanning} {
list [scan {1234567890a} %f x] $x
} {1 1234567890.0}
test scan-4.51 {Tcl_ScanObjCmd, float scanning} {
list [scan {+123+45} %f x] $x
} {1 123.0}
test scan-4.52 {Tcl_ScanObjCmd, float scanning} {
list [scan {-123+45} %f x] $x
} {1 -123.0}
test scan-4.53 {Tcl_ScanObjCmd, float scanning} {
list [scan {1.0e1} %f x] $x
} {1 10.0}
test scan-4.54 {Tcl_ScanObjCmd, float scanning} {
list [scan {1.0e-1} %f x] $x
} {1 0.1}
#test scan-4.55 {Tcl_ScanObjCmd, odd cases} {
# set x {}
# list [scan {+} %f x] $x
#} {-1 {}}
test scan-4.56 {Tcl_ScanObjCmd, odd cases} {
set x {}
list [scan {1.0e} %f%s x y] $x $y
} {2 1.0 e}
test scan-4.57 {Tcl_ScanObjCmd, odd cases} {
set x {}
list [scan {1.0e+} %f%s x y] $x $y
} {2 1.0 e+}
test scan-4.58 {Tcl_ScanObjCmd, odd cases} {
set x {}
set y {}
list [scan {e1} %f%s x y] $x $y
} {0 {} {}}
test scan-4.59 {Tcl_ScanObjCmd, float scanning} {
list [scan {1.0e-1x} %*f%n x] $x
} {1 6}
test scan-4.60 {Tcl_ScanObjCmd, set errors} {
set x {}
set y {}
set z 1
set result [list [catch {scan {abc def ghi} {%s%s%s} x z(z) y} msg] \
$x $y]
set result
} {1 abc ghi}
test scan-4.61 {Tcl_ScanObjCmd, set errors} {
set x {}
set y 1
set z 1
set result [list [catch {scan {abc def ghi} {%s%s%s} x y(y) z(z)} msg] \
$x]
set result
} {1 abc}
# procedure that returns the range of integers
# On Tcl with bignum, these won't produce a result!
proc int_range {} {
for { set MIN_INT 1 } { $MIN_INT > 0 } {} {
set MIN_INT [expr { $MIN_INT << 1 }]
}
set MAX_INT [expr { ~ $MIN_INT }]
return [list $MIN_INT $MAX_INT]
}
test scan-4.62 {scanning of large and negative octal integers} jim {
foreach { MIN_INT MAX_INT } [int_range] {}
set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT]
list [scan $scanstring {%o %o %o} a b c] \
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
test scan-4.63 {scanning of large and negative hex integers} jim {
foreach { MIN_INT MAX_INT } [int_range] {}
set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT]
list [scan $scanstring {%x %x %x} a b c] \
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
# clean up from last two tests
catch {
rename int_range {}
}
test scan-5.1 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d
} {4 -20 1476 33 0}
test scan-5.2 {integer scanning} {
set a {}; set b {}; set c {}
list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c
} {3 -4 16 7890}
test scan-5.3 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d
} {4 -45 16 10 987}
test scan-5.4 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d
} {4 14 427 50 16}
test scan-5.5 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \
$a $b $c $d
} {4 2739128 342391 561323 52719}
test scan-5.6 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d
} {4 171 291 -20 52}
test scan-5.7 {integer scanning} {
set a {}; set b {}
list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b
} {2 17767 375}
test scan-5.8 {integer scanning} {
set a {}; set b {}
list [scan "a 1234" "%d %d" a b] $a $b
} {0 {} {}}
test scan-5.9 {integer scanning} {
set a {}; set b {}; set c {}; set d {};
list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d
} {4 12 34 56 78}
test scan-5.10 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
} {2 1 2 {} {}}
#
# The behavior for scaning intergers larger than MAX_INT is
# not defined by the ANSI spec. Some implementations wrap the
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {
set a {}; set b {};
list [scan "4294967280 4294967280" "%u %d" a b] $a \
[expr {$b == -16 || $b == 0x7fffffff || $b == $a}]
} {2 4294967280 1}
test scan-6.1 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d
} {4 -1.0 234.0 5.0 8.2}
test scan-6.3 {floating-point scanning} {
set a {}; set b {}; set c {}
list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c
} {3 10000.0 30000.0}
#
# Some libc implementations consider 3.e- bad input. The ANSI
# spec states that digits must follow the - sign.
#
test scan-6.4 {floating-point scanning} {
set a {}; set b {}; set c {}
list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c
} {3 1.0 200.0 3.0}
test scan-6.5 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d
} {4 4.6 99999.7 87.643 118.0}
test scan-6.6 {floating-point scanning} jim {
set a {}; set b {}; set c {}; set d {}
list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d
} {4 1.2345 0.697 124.0 5e-05}
test scan-6.7 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} {2 4.6 5.2 {} {}}
test scan-7.1 {string and character scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d
} {4 97 32 b cdef}
test scan-7.3 {string and character scanning} {
set a {}; set b {}; set c {}
list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c
} {1 test {} {}}
test scan-7.4 {string and character scanning} {
set a {}; set b {}; set c {}; set d
list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d
} {4 abab cd {01234 } {f 12345}}
test scan-7.5 {string and character scanning} {
set a {}; set b {}; set c {}
list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c
} {3 aabc bcdefg 43}
test scan-7.6 {string and character scanning, unicode} utf8 {
set a {}; set b {}; set c {}; set d {}
list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} "4 abc d\u00c7f ghijk dum"
test scan-7.7 {string and character scanning, unicode} utf8 {
set a {}; set b {}
list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b
} "2 199 99"
test scan-7.8 {string and character scanning, unicode} utf8 {
set a {}; set b {}
list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a
} "1 ab\ufeff"
test scan-8.1 {error conditions} {
catch {scan a}
} 1
test scan-8.2 {error conditions} jim {
catch {scan a} msg
set msg
} {wrong # args: should be "scan string format ?varName varName ...?"}
test scan-8.3 {error conditions} jim {
list [catch {scan a %D x} msg] $msg
} {1 {bad scan conversion character}}
test scan-8.4 {error conditions} jim {
list [catch {scan a %O x} msg] $msg
} {1 {bad scan conversion character}}
test scan-8.5 {error conditions} jim {
list [catch {scan a %X x} msg] $msg
} {1 {bad scan conversion character}}
test scan-8.6 {error conditions} jim {
list [catch {scan a %F x} msg] $msg
} {1 {bad scan conversion character}}
test scan-8.7 {error conditions} jim {
list [catch {scan a %E x} msg] $msg
} {1 {bad scan conversion character}}
test scan-8.8 {error conditions} {
list [catch {scan a "%d %d" a} msg] $msg
} {1 {different numbers of variable names and field specifiers}}
test scan-8.9 {error conditions} {
list [catch {scan a "%d %d" a b c} msg] $msg
} {1 {variable is not assigned by any conversion specifiers}}
test scan-8.10 {error conditions} {
set a {}; set b {}; set c {}; set d {}
list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d
} {1 {} {} {} {}}
test scan-8.11 {error conditions} {
set a {}; set b {}; set c {}; set d {}
list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d
} {2 1 2 {} {}}
test scan-8.12 {error conditions} {
set a 44
list [catch {scan 44 %d a(0)} msg]
} {1}
test scan-8.13 {error conditions} {
set a 44
list [catch {scan 44 %c a(0)} msg]
} {1}
test scan-8.14 {error conditions} {
set a 44
list [catch {scan 44 %s a(0)} msg]
} {1}
test scan-8.15 {error conditions} {
set a 44
list [catch {scan 44 %f a(0)} msg]
} {1}
catch {unset a}
test scan-8.17 {error conditions} {
list [catch {scan 44 %2c a} msg] $msg
} {1 {field width may not be specified in %c conversion}}
test scan-8.18 {error conditions} {
list [catch {scan abc {%[} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-8.19 {error conditions} {
list [catch {scan abc {%[^a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-8.20 {error conditions} {
list [catch {scan abc {%[^]a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-8.21 {error conditions} {
list [catch {scan abc {%[]a} x} msg] $msg
} {1 {unmatched [ in format string}}
test scan-9.1 {lots of arguments} {
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
} 20
test scan-9.2 {lots of arguments} {
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
set a20
} 200
test scan-10.1 {miscellaneous tests} {
set a {}
list [scan ab16c ab%dc a] $a
} {1 16}
test scan-10.2 {miscellaneous tests} {
set a {}
list [scan ax16c ab%dc a] $a
} {0 {}}
test scan-10.3 {miscellaneous tests} {
set a {}
list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a
} {0 1 114}
test scan-10.4 {miscellaneous tests} {
set a {}
list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a
} {0 1 14}
test scan-10.5 {miscellaneous tests} {
catch {unset arr}
set arr(2) {}
list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2)
} {0 1 14}
test scan-11.1 {alignment in results array (TCL_ALIGN)} {
scan "123 13.6" "%s %f" a b
set b
} 13.6
test scan-11.2 {alignment in results array (TCL_ALIGN)} {
scan "1234567 13.6" "%s %f" a b
set b
} 13.6
test scan-11.3 {alignment in results array (TCL_ALIGN)} {
scan "12345678901 13.6" "%s %f" a b
set b
} 13.6
test scan-11.4 {alignment in results array (TCL_ALIGN)} {
scan "123456789012345 13.6" "%s %f" a b
set b
} 13.6
test scan-11.5 {alignment in results array (TCL_ALIGN)} {
scan "1234567890123456789 13.6" "%s %f" a b
set b
} 13.6
test scan-12.1 {Tcl_ScanObjCmd, inline case} {
scan a %c
} 97
test scan-12.2 {Tcl_ScanObjCmd, inline case} {
scan abc %c%c%c%c
} {97 98 99 {}}
test scan-12.3 {Tcl_ScanObjCmd, inline case} {
scan abc %s%c
} {abc {}}
test scan-12.4 {Tcl_ScanObjCmd, inline case, underflow} {
scan abc abc%c
} {}
test scan-12.5 {Tcl_ScanObjCmd, inline case} {
scan abc bogus%c%c%c
} {{} {} {}}
test scan-12.6 {Tcl_ScanObjCmd, inline case} {
# degenerate case, behavior changed from 8.2 to 8.3
list [catch {scan foo foobar} msg] $msg
} {0 {}}
test scan-12.7 {Tcl_ScanObjCmd, inline case lots of arguments} {
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140\
150 160 170 180 190 200" \
"%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d"
} {10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 {}}
test scan-13.1 {Tcl_ScanObjCmd, inline XPG case} {
scan a {%1$c}
} 97
test scan-13.2 {Tcl_ScanObjCmd, inline XPG case} {
scan abc {%1$c%2$c%3$c%4$c}
} {97 98 99 {}}
test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} {
list [catch {scan abc {%1$c%1$c}} msg] $msg
} {1 {variable is assigned by multiple "%n$" conversion specifiers}}
test scan-13.4 {Tcl_ScanObjCmd, inline XPG case} {
scan abc {%2$s%1$c}
} {{} abc}
test scan-13.5 {Tcl_ScanObjCmd, inline XPG case, underflow} {
scan abc {abc%5$c}
} {}
test scan-13.6 {Tcl_ScanObjCmd, inline XPG case} {
catch {scan abc {bogus%1$c%5$c%10$c}} msg
list [llength $msg] $msg
} {10 {{} {} {} {} {} {} {} {} {} {}}}
test scan-13.7 {Tcl_ScanObjCmd, inline XPG case lots of arguments} {
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" {%20$d %18$d %17$d %16$d %15$d %14$d %13$d %12$d %11$d %10$d %9$d %8$d %7$d %6$d %5$d %4$d %3$d %2$d %1$d}
} {190 180 170 160 150 140 130 120 110 100 90 80 70 60 50 40 30 20 {} 10}
test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} {
set msg [scan "10 20 30" {%100$d %5$d %200$d}]
list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199]
} {200 10 20 30}
test scan-14.1 {scan with null chars} {
scan a\0c %c%c%c
} {97 0 99}
test scan-14.2 {scan with null chars} {
scan \0\0c %c%c%c
} {0 0 99}
test scan-14.3 {scan with null chars} {
scan ab12x\0 %cb%dx%c
} {97 12 0}
testreport

97
debuggers/openocd/jimtcl/tests/signal.test Normal file
View File

@ -0,0 +1,97 @@
source [file dirname [info script]]/testing.tcl
needs cmd signal
needs cmd pid
test signal-1.1 "catch/throw" {
signal handle TERM
set x 1
set rc [catch -signal {
signal throw -TERM
incr x
} result]
signal default TERM
list [info returncode $rc] $result $x
} {signal SIGTERM 1}
test signal-1.2 "catch/kill" {
signal handle TERM
set x 1
set rc [catch -signal {
kill -TERM [pid]
incr x
} result]
signal default TERM
list [info returncode $rc] $result $x
} {signal SIGTERM 1}
test signal-1.3 "catch/alarm" {
signal handle ALRM
set x 1
set rc [catch -signal {
alarm .2
sleep 1
incr x
} result]
signal default ALRM
list [info returncode $rc] $result $x
} {signal SIGALRM 1}
test signal-1.4 "multiple signals before catch" {
signal handle ALRM INT
kill -INT [pid]
alarm .2
sleep 1
set x 1
set rc [catch -signal {
# Doesn't not execute because signals already active
incr x
} result]
signal default ALRM INT
list [info returncode $rc] [lsort $result] $x
} {signal {SIGALRM SIGINT} 1}
test signal-1.5 "ignored signals" {
signal handle INT
signal ignore HUP
set x 1
catch -signal {
# Send an ignored signal
kill -HUP [pid]
incr x
# Now a caught signal
kill -INT [pid]
incr x
} result
signal default INT TERM
list [lsort $result] $x
} {SIGINT 2}
test signal-1.6 "check ignored signals" {
list [signal check SIGINT] [signal check]
} {{} SIGHUP}
test signal-1.7 "clearing ignored signals" {
signal check -clear
signal check
} {}
test signal-1.8 "try/signal" {
signal handle ALRM
try -signal {
alarm 0.4
foreach i [range 10] {
sleep 0.1
}
set msg ""
} on signal {msg} {
# Just set msg here
} finally {
alarm 0
}
signal default ALRM
list [expr {$i in {3 4 5}}] $msg
} {1 SIGALRM}
testreport

117
debuggers/openocd/jimtcl/tests/stacktrace.test Normal file
View File

@ -0,0 +1,117 @@
source [file dirname [info script]]/testing.tcl
needs constraint jim; needs cmd package
package require errors
# Make this a proc so that the line numbers don't have to change
proc main {} {
set id1 0
foreach type {badcmd badvar error interpbadvar interpbadcmd package source badpackage returncode} {
set id2 0
incr id1
foreach method {call uplevel eval evalstr} {
incr id2
set exp ""
if {[info exists ::expected(err-$id1.$id2)]} {
set exp $::expected(err-$id1.$id2)
}
test err-$id1.$id2 "Stacktrace on error type $type, method $method" {
set rc [catch {error_caller $type $method} msg]
#puts "\n-----------------\n$type, $method\n[errorInfo $msg]\n\n"
if {$::SHOW_EXPECTED} { puts stderr "\terr-$id1.$id2 {[list $rc $msg [info stacktrace]]}" }
list $rc $msg [info stacktrace]
} $exp
}
}
proc unknown {args} {
error "from unknown"
}
test err-10.1 "Stacktrace on error from unknown (badcmd, call)" {
set rc [catch {error_caller badcmd call} msg]
#puts stderr "err-10.1\n[errorInfo $msg]\n"
#puts stderr "\terr-10.1 {[list $rc $msg [info stacktrace]]}"
list $rc $msg [info stacktrace]
} {1 {from unknown} {{} stacktrace.test 26 {} errors.tcl 6 error_generator errors.tcl 44 error_caller stacktrace.test 30}}
rename unknown ""
set a {one}
set b [list 1 \
2 \
3]
set c {two}
set d "list 1
2
3"
set e {three}
set f "list 1 \
2 \
3"
set g {four}
test source-1.1 "Basic line numbers" {
info source $a
} {stacktrace.test 39}
test source-1.2 "Line numbers after command with escaped newlines" {
info source $c
} {stacktrace.test 43}
test source-1.3 "Line numbers after string with newlines" {
info source $e
} {stacktrace.test 47}
test source-1.4 "Line numbers after string with escaped newlines" {
info source $g
} {stacktrace.test 51}
}
set expected {
err-1.1 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-1.2 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-1.3 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-1.4 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-2.1 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-2.2 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-2.3 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-2.4 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-3.1 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-3.2 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-3.3 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-3.4 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-4.1 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-4.2 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-4.3 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-4.4 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-5.1 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-5.2 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-5.3 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-5.4 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-6.1 {1 {from dummyproc
Can't load package dummy} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-6.2 {1 {from dummyproc
Can't load package dummy} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-6.3 {1 {from dummyproc
Can't load package dummy} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-6.4 {1 {from dummyproc
Can't load package dummy} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-7.1 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-7.2 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-7.3 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-7.4 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-8.1 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
err-8.2 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
err-8.3 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
err-8.4 {1 {Can't load package bogus} {{} errors.tcl 27 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
err-9.1 {1 failure {{} errors.tcl 44 error_caller stacktrace.test 17}}
err-9.2 {1 failure {{} errors.tcl 47 error_caller stacktrace.test 17}}
err-9.3 {1 failure {{} errors.tcl 50 error_caller stacktrace.test 17}}
err-9.4 {1 failure {{} errors.tcl 53 error_caller stacktrace.test 17}}
}
# Set this to output expected results to stderr
# in a form which can be pasted into 'expected' below
set SHOW_EXPECTED 0
main
testreport

904
debuggers/openocd/jimtcl/tests/string.test Normal file
View File

@ -0,0 +1,904 @@
# Commands covered: string
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: string.test,v 1.23.2.1 2001/04/03 22:54:38 hobbs Exp $
source [file dirname [info script]]/testing.tcl
# Some tests require the testobj command
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg]
} {1}
test string-1.2 {error conditions} {
list [catch {string} msg]
} {1}
test string-2.1 {string compare, too few args} {
list [catch {string compare a} msg]
} {1}
test string-2.2 {string compare, bad args} {
list [catch {string compare a b c} msg]
} {1}
test string-2.3 {string compare, bad args} {
list [catch {string compare -length -nocase str1 str2} msg]
} {1}
test string-2.4 {string compare, too many args} {
list [catch {string compare -length 10 -nocase str1 str2 str3} msg]
} {1}
test string-2.5 {string compare with length unspecified} {
list [catch {string compare -length 10 10} msg]
} {1}
test string-2.6 {string compare} {
string compare abcde abdef
} -1
test string-2.7 {string compare, shortest method name} {
string c abcde ABCDE
} 1
test string-2.8 {string compare} {
string compare abcde abcde
} 0
test string-2.9 {string compare with length} {
string compare -length 2 abcde abxyz
} 0
test string-2.10 {string compare with special index} {
list [catch {string compare -length end-3 abcde abxyz} msg]
} {1}
test string-2.12 {string compare, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
string compare "\x80" "@"
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 1
test string-2.13 {string compare -nocase} {
string compare -nocase abcde abdef
} -1
test string-2.14 {string compare -nocase} {
string c -nocase abcde ABCDE
} 0
test string-2.15 {string compare -nocase} {
string compare -nocase abcde abcde
} 0
test string-2.16 {string compare -nocase with length} {
string compare -length 2 -nocase abcde Abxyz
} 0
test string-2.17 {string compare -nocase with length} {
string compare -nocase -length 3 abcde Abxyz
} -1
test string-2.18 {string compare -nocase with length <= 0} {
string compare -nocase -length -1 abcde AbCdEf
} -1
test string-2.19 {string compare -nocase with excessive length} {
string compare -nocase -length 50 AbCdEf abcde
} 1
test string-2.20 {string compare -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
string compare -len 5 \334\334\334 \334\334\374
} -1
test string-2.21 {string compare -nocase with special index} {
list [catch {string compare -nocase -length end-3 Abcde abxyz} msg]
} {1}
test string-2.22 {string compare, null strings} {
string compare "" ""
} 0
test string-2.23 {string compare, null strings} {
string compare "" foo
} -1
test string-2.24 {string compare, null strings} {
string compare foo ""
} 1
test string-2.25 {string compare -nocase, null strings} {
string compare -nocase "" ""
} 0
test string-2.26 {string compare -nocase, null strings} {
string compare -nocase "" foo
} -1
test string-2.27 {string compare -nocase, null strings} {
string compare -nocase foo ""
} 1
test string-2.28 {string equal with length, unequal strings} {
string compare -length 2 abc abde
} 0
test string-2.29 {string equal with length, unequal strings} {
string compare -length 2 ab abde
} 0
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test string-3.1 {string equal} {
string equal abcde abdef
} 0
test string-3.2 {string equal} {
string eq abcde ABCDE
} 0
test string-3.3 {string equal} {
string equal abcde abcde
} 1
test string-3.4 {string equal -nocase} utf8 {
string equal -nocase \u00dc\u00dc\u00dc\u00dc\u00fc\u00fc\u00fc\u00fc \u00dc\u00dc\u00dc\u00dc\u00dc\u00dc\u00dc\u00dc
} 1
test string-3.5 {string equal -nocase} {
string equal -nocase abcde abdef
} 0
test string-3.6 {string equal -nocase} {
string eq -nocase abcde ABCDE
} 1
test string-3.7 {string equal -nocase} {
string equal -nocase abcde abcde
} 1
test string-3.8 {string equal with length, unequal strings} {
string equal -length 2 abc abde
} 1
test string-4.1 {string first, too few args} {
list [catch {string first a} msg]
} {1}
test string-4.2 {string first, bad args} {
list [catch {string first a b c} msg]
} {1}
test string-4.3 {string first, too many args} {
list [catch {string first a b 5 d} msg]
} {1}
test string-4.4 {string first} {
string first bq abcdefgbcefgbqrs
} 12
test string-4.5 {string first} {
string fir bcd abcdefgbcefgbqrs
} 1
test string-4.6 {string first} {
string f b abcdefgbcefgbqrs
} 1
test string-4.7 {string first} {
string first xxx x123xx345xxx789xxx012
} 9
test string-4.8 {string first} {
string first "" x123xx345xxx789xxx012
} -1
test string-4.14 {string first, start index} {
string first a abcabc end-4
} 3
test string-4.15 {string first, empty needle} {
string first "" b
} -1
test string-4.16 {string first, empty haystack} {
string first a ""
} -1
test string-4.17 {string first, needle bigger than haystack} {
string first aaa b
} -1
test string-4.18 {string first, negative index} {
string first a aaa -4
} 0
test string-4.19 {string first, not found} {
string first a bcd
} -1
test string-5.1 {string index} {
list [catch {string index} msg]
} {1}
test string-5.2 {string index} {
list [catch {string index a b c} msg]
} {1}
test string-5.3 {string index} {
string index abcde 0
} a
test string-5.4 {string index} {
string in abcde 4
} e
test string-5.5 {string index} {
string index abcde 5
} {}
test string-5.6 {string index} {
list [catch {string index abcde -10} msg]
} {0}
test string-5.7 {string index} {
list [catch {string index a xyz} msg]
} {1}
test string-5.8 {string index} {
string index abc end
} c
test string-5.9 {string index} {
string index abc end-1
} b
test string-5.17 {string index, bad integer} tcl {
list [catch {string index "abc" 08} msg]
} {1}
test string-5.18 {string index, bad integer} tcl {
list [catch {string index "abc" end-00289} msg]
} {1}
test string-6.1 {string is, too few args} jim {
list [catch {string is} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? str"}}
test string-6.2 {string is, too few args} jim {
list [catch {string is alpha} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? str"}}
test string-6.3 {string is, bad args} jim {
list [catch {string is alpha -failin str} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? str"}}
test string-6.4 {string is, too many args} jim {
list [catch {string is alpha -failin var -strict str more} msg] $msg
} {1 {wrong # args: should be "string is class ?-strict? str"}}
test string-6.5 {string is, class check} jim {
list [catch {string is bogus str} msg] $msg
} {1 {bad class "bogus": must be alnum, alpha, ascii, control, digit, double, graph, integer, lower, print, punct, space, upper, or xdigit}}
test string-6.6 {string is, ambiguous class} jim {
list [catch {string is al str} msg] $msg
} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, digit, double, graph, integer, lower, print, punct, space, upper, or xdigit}}
test string-6.10 {string is, ok on empty} {
string is alpha {}
} 1
test string-6.11 {string is, -strict check against empty} {
string is alpha -strict {}
} 0
test string-6.12 {string is alnum, true} {
string is alnum abc123
} 1
test string-6.15 {string is alpha, true} {
string is alpha abc
} 1
test string-6.24 {string is digit, true} {
string is digit 0123456789
} 1
test string-6.25 {string is digit, false} {
list [string is digit 0123Ü567]
} {0}
test string-6.26 {string is digit, false} {
list [string is digit +123567]
} {0}
test string-6.27 {string is double, true} {
string is double 1
} 1
test string-6.28 {string is double, true} {
string is double [expr double(1)]
} 1
test string-6.29 {string is double, true} {
string is double 1.0
} 1
test string-6.30 {string is double, true} {
string is double [string compare a a]
} 1
test string-6.31 {string is double, true} {
string is double " +1.0e-1 "
} 1
test string-6.32 {string is double, true} {
string is double "\n1.0\v"
} 1
test string-6.33 {string is double, false} {
list [string is double 1abc]
} {0}
test string-6.34 {string is double, false} {
list [string is double abc]
} {0}
test string-6.35 {string is double, false} {
list [string is double " 1.0e4e4 "]
} {0}
test string-6.36 {string is double, false} {
list [string is double "\n"]
} {0}
test string-6.38 {string is double, false on underflow} jim {
list [string is double 123e-9999]
} {0}
test string-6.39 {string is double, false} {
# This test is non-portable because IRIX thinks
# that .e1 is a valid double - this is really a bug
# on IRIX as .e1 should NOT be a valid double
list [string is double .e1]
} {0}
test string-6.48 {string is integer, true} {
string is integer +1234567890
} 1
test string-6.49 {string is integer, true on type} {
string is integer [expr int(50.0)]
} 1
test string-6.50 {string is integer, true} {
string is integer [list -10]
} 1
test string-6.51 {string is integer, true as hex} {
string is integer 0xabcdef
} 1
test string-6.52 {string is integer, true as octal} {
string is integer 012345
} 1
test string-6.53 {string is integer, true with whitespace} {
string is integer " \n1234\v"
} 1
test string-6.54 {string is integer, false} {
list [string is integer 123abc]
} 0
test string-6.56 {string is integer, false} {
list [string is integer [expr double(1)]]
} 0
test string-6.57 {string is integer, false} {
list [string is integer " "]
} 0
test string-6.58 {string is integer, false on bad octal} jim {
list [string is integer 036963]
} 1
test string-6.59 {string is integer, false on bad octal} tcl {
list [string is integer 036963]
} 0
test string-6.60 {string is integer, false on bad hex} {
list [string is integer 0X345XYZ]
} 0
test string-6.61 {string is lower, true} {
string is lower abc
} 1
test string-6.62 {string is lower, false} {
list [string is lower aBc]
} 0
test string-6.63 {string is lower, false} {
list [string is lower abc1]
} 0
test string-6.64 {string is lower, unicode false} {
list [string is lower abÜUE]
} 0
test string-6.65 {string is space, true} {
string is space " \t\n\v\f"
} 1
test string-6.66 {string is space, false} {
list [string is space " \t\n\v1\f"]
} 0
test string-6.75 {string is upper, true} {
string is upper ABC
} 1
test string-6.77 {string is upper, false} {
list [string is upper AbC]
} 0
test string-6.78 {string is upper, false} {
list [string is upper AB2C]
} 0
test string-6.84 {string is control} {
## Control chars are in the ranges
## 00..1F && 7F..9F
list [string is control \x00\x01\x10\x1F\x7F\x80\x9F\x60]
} 0
test string-6.85 {string is control} tcl {
string is control \u0100
} 0
test string-6.86 {string is graph} {
## graph is any print char, except space
list [string is gra "0123abc!@#\$ "]
} 0
test string-6.87 {string is print} {
## basically any printable char
list [string is print "0123abc!@#\$ \010"]
} 0
test string-6.88 {string is punct} {
## any graph char that isn't alnum
list [string is punct "_!@#\000beq0"]
} 0
test string-6.89 {string is xdigit} {
list [string is xdigit 0123456789\u0061bcdefABCDEFg]
} 0
test string-7.1 {string last, too few args} {
list [catch {string last a} msg]
} {1}
test string-7.2 {string last, bad args} {
list [catch {string last a b c} msg]
} {1}
test string-7.3 {string last, too many args} {
list [catch {string last a b c d} msg]
} {1}
test string-7.4 {string last} {
string la xxx xxxx123xx345x678
} 1
test string-7.5 {string last} {
string last xx xxxx123xx345x678
} 7
test string-7.6 {string last} {
string las x xxxx123xx345x678
} 12
test string-7.13 {string last, start index} {
## Constrain to last 'a' should work
string last ba badbad end-1
} 3
test string-7.14 {string last, start index} {
## Constrain to last 'b' should skip last 'ba'
string last ba badbad end-2
} 0
test string-7.15 {string last, start index} {
string last \u00dca \u00dcad\u00dcad 0
} -1
test string-7.16 {string last, start index} utf8 {
string last \u00dca \u00dcad\u00dcad end-1
} 3
test string-7.17 {string last, too few args} {
string last abc def
} -1
test string-9.1 {string length} {
list [catch {string length} msg]
} {1}
test string-9.2 {string length} {
list [catch {string length a b} msg]
} {1}
test string-9.3 {string length} {
string length "a little string"
} 15
test string-9.4 {string length} {
string le ""
} 0
test string-10.1 {string map, too few args} {
list [catch {string map} msg]
} {1}
test string-10.2 {string map, bad args} {
list [catch {string map {a b} abba oops} msg]
} {1}
test string-10.3 {string map, too many args} {
list [catch {string map -nocase {a b} str1 str2} msg]
} {1}
test string-10.4 {string map} {
string map {a b} abba
} {bbbb}
test string-10.5 {string map} {
string map {a b} a
} {b}
test string-10.6 {string map -nocase} {
string map -nocase {a b} Abba
} {bbbb}
test string-10.7 {string map} {
string map {abc 321 ab * a A} aabcabaababcab
} {A321*A*321*}
test string-10.8 {string map -nocase} {
string map -nocase {aBc 321 Ab * a A} aabcabaababcab
} {A321*A*321*}
test string-10.9 {string map -nocase} {
string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb
} {A321*A*321*}
test string-10.10 {string map} {
list [catch {string map {a b c} abba} msg]
} {1}
test string-10.11 {string map, nulls} {
string map {\x00 NULL blah \x00nix} {qwerty}
} {qwerty}
test string-10.12 {string map, unicode} {
string map [list \u00fc ue UE \u00dc] "a\u00fcueUE\000EU"
} aueue\u00dc\0EU
test string-10.13 {string map, -nocase unicode} {
string map -nocase [list \u00fc ue UE \u00dc] "a\u00fcueUE\000EU"
} aue\u00dc\u00dc\0EU
test string-10.14 {string map, -nocase null arguments} {
string map -nocase {{} abc} foo
} foo
test string-10.15 {string map, one pair case} {
string map -nocase {abc 32} aAbCaBaAbAbcAb
} {a32aBaAb32Ab}
test string-10.16 {string map, one pair case} {
string map -nocase {ab 4321} aAbCaBaAbAbcAb
} {a4321C4321a43214321c4321}
test string-10.17 {string map, one pair case} {
string map {Ab 4321} aAbCaBaAbAbcAb
} {a4321CaBa43214321c4321}
test string-11.1 {string match, too few args} {
list [catch {string match a} msg]
} {1}
test string-11.2 {string match, too many args} {
list [catch {string match a b c d} msg]
} {1}
test string-11.3 {string match} {
string match abc abc
} 1
test string-11.4 {string match} {
string mat abc abd
} 0
test string-11.5 {string match} {
string match ab*c abc
} 1
test string-11.6 {string match} {
string match ab**c abc
} 1
test string-11.7 {string match} {
string match ab* abcdef
} 1
test string-11.8 {string match} {
string match *c abc
} 1
test string-11.9 {string match} {
string match *3*6*9 0123456789
} 1
test string-11.10 {string match} {
string match *3*6*9 01234567890
} 0
test string-11.11 {string match} {
string match a?c abc
} 1
test string-11.12 {string match} {
string match a??c abc
} 0
test string-11.13 {string match} {
string match ?1??4???8? 0123456789
} 1
test string-11.14 {string match} {
string match {[abc]bc} abc
} 1
test string-11.15 {string match} {
string match {a[abc]c} abc
} 1
test string-11.16 {string match} {
string match {a[xyz]c} abc
} 0
test string-11.17 {string match} {
string match {12[2-7]45} 12345
} 1
test string-11.18 {string match} {
string match {12[ab2-4cd]45} 12345
} 1
test string-11.19 {string match} {
string match {12[ab2-4cd]45} 12b45
} 1
test string-11.20 {string match} {
string match {12[ab2-4cd]45} 12d45
} 1
test string-11.21 {string match} {
string match {12[ab2-4cd]45} 12145
} 0
test string-11.22 {string match} {
string match {12[ab2-4cd]45} 12545
} 0
test string-11.23 {string match} {
string match {a\*b} a*b
} 1
test string-11.24 {string match} {
string match {a\*b} ab
} 0
test string-11.25 {string match} {
string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
} 1
test string-11.26 {string match} {
string match ** ""
} 1
test string-11.27 {string match} {
string match *. ""
} 0
test string-11.28 {string match} {
string match "" ""
} 1
test string-11.29 {string match} {
string match \[a a
} 1
test string-11.30 {string match, bad args} {
list [catch {string match - b c} msg]
} {1}
test string-11.31 {string match case} {
string match a A
} 0
test string-11.32 {string match nocase} {
string match -nocase a A
} 1
test string-11.34 {string match nocase} {
string match -nocase a*f ABCDEf
} 1
test string-11.35 {string match case, false hope} {
# This is true because '_' lies between the A-Z and a-z ranges
string match {[A-z]} _
} 1
test string-11.36 {string match nocase range} {
# This is false because although '_' lies between the A-Z and a-z ranges,
# we lower case the end points before checking the ranges.
string match -nocase {[A-z]} _
} 0
test string-11.37 {string match nocase} {
string match -nocase {[A-fh-Z]} g
} 0
test string-11.38 {string match case, reverse range} {
string match {[A-fh-Z]} g
} 1
test string-11.39 {string match, *\ case} {
string match {*\abc} abc
} 1
test string-11.40 {string match, *special case} {
string match {*[ab]} abc
} 0
test string-11.41 {string match, *special case} {
string match {*[ab]*} abc
} 1
# I don't see why this shouldn't match. Ignored for jim
test string-11.42 {string match, *special case} tcl {
string match "*\\" "\\"
} 0
test string-11.43 {string match, *special case} {
string match "*\\\\" "\\"
} 1
test string-11.44 {string match, *special case} {
string match "*???" "12345"
} 1
test string-11.45 {string match, *special case} {
string match "*???" "12"
} 0
test string-11.46 {string match, *special case} {
string match "*\\*" "abc*"
} 1
test string-11.47 {string match, *special case} {
string match "*\\*" "*"
} 1
test string-11.48 {string match, *special case} {
string match "*\\*" "*abc"
} 0
test string-11.49 {string match, *special case} {
string match "?\\*" "a*"
} 1
# I don't see why this shouldn't match. Ignored for jim
test string-11.50 {string match, *special case} tcl {
string match "\\" "\\"
} 0
test string-12.1 {string range} {
list [catch {string range} msg]
} {1}
test string-12.2 {string range} {
list [catch {string range a 1} msg]
} {1}
test string-12.3 {string range} {
list [catch {string range a 1 2 3} msg]
} {1}
test string-12.4 {string range} {
string range abcdefghijklmnop 2 14
} {cdefghijklmno}
test string-12.5 {string range, last > length} {
string range abcdefghijklmnop 7 1000
} {hijklmnop}
test string-12.6 {string range} {
string range abcdefghijklmnop 10 end
} {klmnop}
test string-12.7 {string range, last < first} {
string range abcdefghijklmnop 10 9
} {}
test string-12.8 {string range, first < 0} {
string range abcdefghijklmnop -3 2
} {abc}
test string-12.9 {string range} {
string range abcdefghijklmnop -3 -2
} {}
test string-12.10 {string range} {
string range abcdefghijklmnop 1000 1010
} {}
test string-12.11 {string range} {
string range abcdefghijklmnop -100 end
} {abcdefghijklmnop}
test string-12.12 {string range} {
list [catch {string range abc abc 1} msg]
} {1}
test string-12.13 {string range} {
list [catch {string range abc 1 eof} msg]
} {1}
test string-12.14 {string range} {
string range abcdefghijklmnop end-1 end
} {op}
test string-12.15 {string range} {
string range abcdefghijklmnop end 1000
} {p}
test string-12.16 {string range} {
string range abcdefghijklmnop end end-1
} {}
test string-13.1 {string repeat} {
list [catch {string repeat} msg]
} {1}
test string-13.2 {string repeat} {
list [catch {string repeat abc 10 oops} msg]
} {1}
test string-13.3 {string repeat} {
string repeat {} 100
} {}
test string-13.4 {string repeat} {
string repeat { } 5
} { }
test string-13.5 {string repeat} {
string repeat abc 3
} {abcabcabc}
test string-13.6 {string repeat} {
string repeat abc -1
} {}
test string-13.7 {string repeat} {
list [catch {string repeat abc end} msg]
} {1}
test string-13.8 {string repeat} {
string repeat {} -1000
} {}
test string-13.9 {string repeat} {
string repeat {} 0
} {}
test string-13.10 {string repeat} {
string repeat def 0
} {}
test string-13.11 {string repeat} {
string repeat def 1
} def
test string-13.12 {string repeat} {
string repeat ab\u7266cd 3
} ab\u7266cdab\u7266cdab\u7266cd
test string-13.13 {string repeat} {
string repeat \x00 3
} \x00\x00\x00
test string-14.1 {string replace} {
list [catch {string replace} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.2 {string replace} {
list [catch {string replace a 1} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.3 {string replace} {
list [catch {string replace a 1 2 3 4} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4 {string replace} {
} {}
test string-14.5 {string replace} {
string replace abcdefghijklmnop 2 14
} {abp}
test string-14.6 {string replace} {
string replace abcdefghijklmnop 7 1000
} {abcdefg}
test string-14.7 {string replace} {
string replace abcdefghijklmnop 10 end
} {abcdefghij}
test string-14.8 {string replace} {
string replace abcdefghijklmnop 10 9
} {abcdefghijklmnop}
test string-14.9 {string replace} {
string replace abcdefghijklmnop -3 2
} {defghijklmnop}
test string-14.10 {string replace} {
string replace abcdefghijklmnop -3 -2
} {abcdefghijklmnop}
test string-14.11 {string replace} {
string replace abcdefghijklmnop 1000 1010
} {abcdefghijklmnop}
test string-14.12 {string replace} {
string replace abcdefghijklmnop -100 end
} {}
test string-14.13 {string replace} {
list [catch {string replace abc abc 1} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14 {string replace} {
list [catch {string replace abc 1 eof} msg] $msg
} {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.15 {string replace} {
string replace abcdefghijklmnop end-10 end-2 NEW
} {abcdeNEWop}
test string-14.16 {string replace} {
string replace abcdefghijklmnop 0 end foo
} {foo}
test string-14.17 {string replace} {
string replace abcdefghijklmnop end end-1
} {abcdefghijklmnop}
test string-15.1 {string tolower too few args} {
list [catch {string tolower} msg]
} {1}
test string-15.2 {string tolower bad args} {
list [catch {string tolower a b} msg]
} {1}
test string-15.3 {string tolower too many args} {
list [catch {string tolower ABC 1 end oops} msg]
} {1}
test string-15.4 {string tolower} {
string tolower ABCDeF
} {abcdef}
test string-15.5 {string tolower} {
string tolower "ABC XyZ"
} {abc xyz}
test string-15.6 {string tolower} {
string tolower {123#$&*()}
} {123#$&*()}
test string-16.1 {string toupper} {
list [catch {string toupper} msg]
} {1}
test string-16.2 {string toupper} {
list [catch {string toupper a b} msg]
} {1}
test string-16.4 {string toupper} {
string toupper abCDEf
} {ABCDEF}
test string-16.5 {string toupper} {
string toupper "abc xYz"
} {ABC XYZ}
test string-16.6 {string toupper} {
string toupper {123#$&*()}
} {123#$&*()}
test string-17.1 {string totitle} -body {
string totitle
} -returnCodes error -match glob -result {wrong # args: should be "string totitle string*}
test string-17.3 {string totitle} {
string totitle abCDEf
} {Abcdef}
test string-17.4 {string totitle} {
string totitle "abc xYz"
} {Abc xyz}
test string-17.5 {string totitle} {
string totitle {123#$&*()}
} {123#$&*()}
test string-18.1 {string trim} {
list [catch {string trim} msg]
} {1}
test string-18.2 {string trim} {
list [catch {string trim a b c} msg]
} {1}
test string-18.3 {string trim} {
string trim " XYZ "
} {XYZ}
test string-18.4 {string trim} {
string trim "\t\nXYZ\t\n\r\n"
} {XYZ}
test string-18.5 {string trim} {
string trim " A XYZ A "
} {A XYZ A}
test string-18.6 {string trim} {
string trim "XXYYZZABC XXYYZZ" ZYX
} {ABC }
test string-18.7 {string trim} {
string trim " \t\r "
} {}
test string-18.8 {string trim} {
string trim {abcdefg} {}
} {abcdefg}
test string-18.9 {string trim} {
string trim {}
} {}
test string-18.10 {string trim} {
string trim ABC DEF
} {ABC}
test string-18.11 {string trim, unicode} {
string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8
} " AB\xe7C "
test string-19.1 {string trimleft} {
list [catch {string trimleft} msg]
} {1}
test string-19.2 {string trimleft} {
string trimleft " XYZ "
} {XYZ }
test string-20.1 {string trimright errors} {
list [catch {string trimright} msg]
} {1}
test string-20.2 {string trimright errors} {
list [catch {string trimg a} msg]
} {1}
test string-20.3 {string trimright} {
string trimright " XYZ "
} { XYZ}
test string-20.4 {string trimright} {
string trimright " "
} {}
test string-20.5 {string trimright} {
string trimright ""
} {}
# Test for 8-bit clean and utf-8 trim chars
test string-21.1 {string trim embedded nulls} {
string trim " abc\x00def "
} "abc\x00def"
test string-21.2 {string trimleft embedded nulls} {
string trimleft " abc\x00def "
} "abc\x00def "
test string-21.3 {string trimright embedded nulls} {
string trimright " abc\x00def "
} " abc\x00def"
test string-21.4 {string trim utf-8} {
string trim "\u00b5\u00b6abc\x00def\u00b5\u00b5" "\u00b5\u00b6"
} "abc\x00def"
test string-22.1 {string replace} {
string replace //test.net/path/path2?query=url?otherquery 21 end
} {//test.net/path/path2}
testreport

225
debuggers/openocd/jimtcl/tests/stringmatch.test Normal file
View File

@ -0,0 +1,225 @@
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: util.test,v 1.7.2.1 2001/07/16 23:14:13 hobbs Exp $
source [file dirname [info script]]/testing.tcl
test stringmatch-5.1 {Tcl_StringMatch} {
string match ab*c abc
} 1
test stringmatch-5.2 {Tcl_StringMatch} {
string match ab**c abc
} 1
test stringmatch-5.3 {Tcl_StringMatch} {
string match ab* abcdef
} 1
test stringmatch-5.4 {Tcl_StringMatch} {
string match *c abc
} 1
test stringmatch-5.5 {Tcl_StringMatch} {
string match *3*6*9 0123456789
} 1
test stringmatch-5.6 {Tcl_StringMatch} {
string match *3*6*9 01234567890
} 0
test stringmatch-5.7 {Tcl_StringMatch: UTF-8} {
string match *u \u4e4fu
} 1
test stringmatch-5.8 {Tcl_StringMatch} {
string match a?c abc
} 1
test stringmatch-5.9 {Tcl_StringMatch: UTF-8} utf8 {
# skip one character in string
string match a?c a\u4e4fc
} 1
test stringmatch-5.10 {Tcl_StringMatch} {
string match a??c abc
} 0
test stringmatch-5.11 {Tcl_StringMatch} {
string match ?1??4???8? 0123456789
} 1
test stringmatch-5.12 {Tcl_StringMatch} {
string match {[abc]bc} abc
} 1
test stringmatch-5.13 {Tcl_StringMatch: UTF-8} utf8 {
# string += Tcl_UtfToUniChar(string, &ch);
string match "\[\u4e4fxy\]bc" "\u4e4fbc"
} 1
test stringmatch-5.14 {Tcl_StringMatch} {
# if ((*pattern == ']') || (*pattern == '\0'))
# badly formed pattern
string match {[]} {[]}
} 0
test stringmatch-5.15 {Tcl_StringMatch} {
# if ((*pattern == ']') || (*pattern == '\0'))
# badly formed pattern
string match {[} {[}
} 0
test stringmatch-5.16 {Tcl_StringMatch} {
string match {a[abc]c} abc
} 1
test stringmatch-5.17 {Tcl_StringMatch: UTF-8} utf8 {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
string match "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test stringmatch-5.18 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
string match {a[a\u4e4fc]c} a\u008fc
} 0
test stringmatch-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance.
string match {a[a\u4e4fc]c} "acc"
} 1
test stringmatch-5.20 {Tcl_StringMatch} {
string match {a[xyz]c} abc
} 0
test stringmatch-5.21 {Tcl_StringMatch} {
string match {12[2-7]45} 12345
} 1
test stringmatch-5.22 {Tcl_StringMatch: UTF-8 range} {
string match "\[\u4e00-\u4e4f]" "0"
} 0
test stringmatch-5.23 {Tcl_StringMatch: UTF-8 range} utf8 {
string match "\[\u4e00-\u4e4f]" "\u4e33"
} 1
test stringmatch-5.24 {Tcl_StringMatch: UTF-8 range} utf8 {
string match "\[\u4e00-\u4e4f]" "\uff08"
} 0
test stringmatch-5.25 {Tcl_StringMatch} {
string match {12[ab2-4cd]45} 12345
} 1
test stringmatch-5.26 {Tcl_StringMatch} {
string match {12[ab2-4cd]45} 12b45
} 1
test stringmatch-5.27 {Tcl_StringMatch} {
string match {12[ab2-4cd]45} 12d45
} 1
test stringmatch-5.28 {Tcl_StringMatch} {
string match {12[ab2-4cd]45} 12145
} 0
test stringmatch-5.29 {Tcl_StringMatch} {
string match {12[ab2-4cd]45} 12545
} 0
test stringmatch-5.30 {Tcl_StringMatch: forwards range} {
string match {[k-w]} "z"
} 0
test stringmatch-5.31 {Tcl_StringMatch: forwards range} {
string match {[k-w]} "w"
} 1
test stringmatch-5.32 {Tcl_StringMatch: forwards range} {
string match {[k-w]} "r"
} 1
test stringmatch-5.33 {Tcl_StringMatch: forwards range} {
string match {[k-w]} "k"
} 1
test stringmatch-5.34 {Tcl_StringMatch: forwards range} {
string match {[k-w]} "a"
} 0
test stringmatch-5.35 {Tcl_StringMatch: reverse range} {
string match {[w-k]} "z"
} 0
test stringmatch-5.36 {Tcl_StringMatch: reverse range} {
string match {[w-k]} "w"
} 1
test stringmatch-5.37 {Tcl_StringMatch: reverse range} {
string match {[w-k]} "r"
} 1
test stringmatch-5.38 {Tcl_StringMatch: reverse range} {
string match {[w-k]} "k"
} 1
test stringmatch-5.39 {Tcl_StringMatch: reverse range} {
string match {[w-k]} "a"
} 0
test stringmatch-5.40 {Tcl_StringMatch: skip correct number of ']'} {
string match {[A-]x} Ax
} 0
test stringmatch-5.41 {Tcl_StringMatch: skip correct number of ']'} {
string match {[A-]]x} Ax
} 1
test stringmatch-5.42 {Tcl_StringMatch: skip correct number of ']'} {
string match {[A-]]x} \ue1x
} 0
test stringmatch-5.43 {Tcl_StringMatch: skip correct number of ']'} utf8 {
string match \[A-]\ue1]x \ue1x
} 1
test stringmatch-5.44 {Tcl_StringMatch: skip correct number of ']'} {
string match {[A-]h]x} hx
} 1
test stringmatch-5.45 {Tcl_StringMatch} {
# if (*pattern == '\0')
# badly formed pattern, still treats as a set
string match {[a} a
} 1
test stringmatch-5.46 {Tcl_StringMatch} {
string match {a\*b} a*b
} 1
test stringmatch-5.47 {Tcl_StringMatch} {
string match {a\*b} ab
} 0
test stringmatch-5.48 {Tcl_StringMatch} {
string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
} 1
test stringmatch-5.49 {Tcl_StringMatch} {
string match ** ""
} 1
test stringmatch-5.50 {Tcl_StringMatch} {
string match *. ""
} 0
test stringmatch-5.51 {Tcl_StringMatch} {
string match "" ""
} 1
# 'string match' doesn't support ^, which is different
# from 'scan'
test stringmatch-6.1 {bracket in charset} {
string match {a[]b]c} {a]c}
} 0
test stringmatch-6.2 {bracket in charset} {
string match {a[]b]c} {abc}
} 0
test stringmatch-6.3 {charset with ^} {
string match {a[^]b]c} {axc}
} 0
test stringmatch-6.4 {charset with ^} {
string match {a[^]b]c} {a]c}
} 0
test stringmatch-6.5 {charset with ^} {
string match {a[^bc]d} {axd}
} 0
test stringmatch-6.6 {charset with ^} {
string match {a[\]]c} {a]c}
} 0
test stringmatch=7.1 {short string with ?} {
string match {ab?} ab
} 0
test stringmatch=7.1 {multiple * to end} {
string match {ab**} ab
} 1
testreport

178
debuggers/openocd/jimtcl/tests/subst.test Normal file
View File

@ -0,0 +1,178 @@
# Commands covered: subst
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: subst.test,v 1.6.2.1 2001/04/03 22:54:38 hobbs Exp $
source [file dirname [info script]]/testing.tcl
test subst-1.0 {basics} {
subst {\$x}
} "\$x"
test subst-1.1 {basics} {
list [catch {subst} msg]
} {1}
test subst-1.2 {basics} {
list [catch {subst a b c} msg]
} {1}
test subst-2.1 {simple strings} {
subst {}
} {}
test subst-2.2 {simple strings} {
subst a
} a
test subst-2.3 {simple strings} {
subst abcdefg
} abcdefg
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
test subst-4.1 {variable substitutions} {
set a 44
subst {$a}
} {44}
test subst-4.2 {variable substitutions} {
set a 44
subst {x$a.y{$a}.z}
} {x44.y{44}.z}
test subst-4.3 {variable substitutions} {
catch {unset a}
set a(13) 82
set i 13
subst {x.$a($i)}
} {x.82}
catch {unset a}
set long {This is a very long string, intentionally made so long that it
will overflow the static character size for dstrings, so that
additional memory will have to be allocated by subst. That way,
if the subst procedure forgets to free up memory while returning
an error, there will be memory that isn't freed (this will be
detected when the tests are run under a checking memory allocator
such as Purify).}
test subst-4.4 {variable substitutions} {
list [catch {subst {$long $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test subst-5.1 {command substitutions} {
subst {[concat {}]}
} {}
test subst-5.2 {command substitutions} {
subst {[concat A test string]}
} {A test string}
test subst-5.3 {command substitutions} {
subst {x.[concat foo].y.[concat bar].z}
} {x.foo.y.bar.z}
test subst-5.4 {command substitutions} {
list [catch {subst {$long [set long] [bogus_command]}} msg] $msg
} {1 {invalid command name "bogus_command"}}
test subst-6.1 {clear the result after command substitution} {
catch {unset a}
list [catch {subst {[concat foo] $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test subst-7.1 {switches} {
list [catch {subst foo bar} msg]
} {1}
test subst-7.2 {switches} {
list [catch {subst -no bar} msg]
} {1}
test subst-7.3 {switches} {
list [catch {subst -bogus bar} msg]
} {1}
test subst-7.4 {switches} {
set x 123
subst -nobackslashes {abc $x [expr 1+2] \\\x41}
} {abc 123 3 \\\x41}
test subst-7.5 {switches} {
set x 123
subst -nocommands {abc $x [expr 1+2] \\\x41}
} {abc 123 [expr 1+2] \A}
test subst-7.6 {switches} {
set x 123
subst -novariables {abc $x [expr 1+2] \\\x41}
} {abc $x 3 \A}
test subst-7.7 {switches} {
set x 123
subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}
test subst-8.1 {return in a subst} {
subst {foo [return {x}; bogus code] bar}
} {foo x bar}
test subst-8.2 {return in a subst} {
subst {foo [return x ; bogus code] bar}
} {foo x bar}
test subst-8.3 {return in a subst} {
subst {foo [if 1 { return {x}; bogus code }] bar}
} {foo x bar}
test subst-8.4 {return in a subst} {
subst {[eval {return hi}] there}
} {hi there}
test subst-8.5 {return in a subst} {
subst {foo [return {]}; bogus code] bar}
} {foo ] bar}
test subst-9.1 {error in a subst} {
list [catch {subst {[error foo; bogus code]bar}} msg] $msg
} {1 foo}
test subst-9.2 {error in a subst} {
list [catch {subst {[if 1 { error foo; bogus code}]bar}} msg] $msg
} {1 foo}
test subst-10.1 {break in a subst} {
subst {foo [break; bogus code] bar}
} {foo }
test subst-10.2 {break in a subst} {
subst {foo [break; return x; bogus code] bar}
} {foo }
test subst-10.3 {break in a subst} {
subst {foo [if 1 { break; bogus code}] bar}
} {foo }
test subst-10.4 {break in a subst, parse error} {
subst {foo [break ; set a {}{} ; stuff] bar}
} {foo }
test subst-10.5 {break in a subst, parse error} {
subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar}
} {foo }
test subst-11.1 {continue in a subst} {
subst {foo [continue; bogus code] bar}
} {foo bar}
test subst-11.2 {continue in a subst} {
subst {foo [continue; return x; bogus code] bar}
} {foo bar}
test subst-11.3 {continue in a subst} {
subst {foo [if 1 { continue; bogus code}] bar}
} {foo bar}
test subst-12.1 {lone $} {
subst {$}
} {$}
test subst-12.2 {lone $} {
set a 1
subst -novar {${a}}
} {${a}}
test subst-12.3 {variable inside [] with -noc} {
set a 1
subst -noc {x[join $a]y}
} {x[join 1]y}
# cleanup
testreport

61
debuggers/openocd/jimtcl/tests/tailcall.test Normal file
View File

@ -0,0 +1,61 @@
source [file dirname [info script]]/testing.tcl
needs cmd tailcall
needs cmd try tclcompat
test tailcall-1.1 {Basic tailcall} {
# Demo -- a tail-recursive factorial function
proc fac {x {val 1}} {
if {$x <= 2} {
expr {$x * $val}
} else {
tailcall fac [expr {$x -1}] [expr {$x * $val}]
}
}
fac 10
} {3628800}
test tailcall-1.2 {Tailcall in try} {
set x 0
proc a {} { upvar x x; incr x }
proc b {} { upvar x x; incr x 4; try { tailcall a } finally { incr x 8 }}
b
set x
} {13}
test tailcall-1.3 {Tailcall does return} {
set x 0
proc a {} { upvar x x; incr x }
proc b {} { upvar x x; incr x 4; tailcall a; incr x 8}
b
set x
} {5}
test tailcall-1.5 {interaction of uplevel and tailcall} {
proc a {cmd} {
tailcall $cmd
}
proc b {} {
lappend result [uplevel 1 a c]
lappend result [uplevel 1 a c]
}
proc c {} {
return c
}
a b
} {c c}
test tailcall-1.6 {tailcall pass through return} {
proc a {script} {
# return from $script should pass through back to the caller
tailcall foreach i {1 2 3} $script
}
proc b {} {
a {return ok}
# Should not get here
return bad
}
b
} {ok}
testreport

231
debuggers/openocd/jimtcl/tests/testing.tcl Normal file
View File

@ -0,0 +1,231 @@
# Common code
set testinfo(verbose) 0
set testinfo(numpass) 0
set testinfo(numfail) 0
set testinfo(numskip) 0
set testinfo(numtests) 0
set testinfo(failed) {}
set testdir [file dirname [info script]]
set bindir [file dirname [info nameofexecutable]]
if {[lsearch $argv "-verbose"] >= 0 || [info exists env(testverbose)]} {
incr testinfo(verbose)
}
proc needs {type what {packages {}}} {
if {$type eq "constraint"} {
if {![info exists ::tcltest::testConstraints($what)]} {
set ::tcltest::testConstraints($what) 0
}
if {![set ::tcltest::testConstraints($what)]} {
skiptest " (constraint $what)"
}
return
}
if {$type eq "cmd"} {
# Does it exist already?
if {[info commands $what] ne ""} {
return
}
if {$packages eq ""} {
# e.g. exec command is in exec package
set packages $what
}
foreach p $packages {
catch {package require $p}
}
if {[info commands $what] ne ""} {
return
}
skiptest " (command $what)"
}
error "Unknown needs type: $type"
}
proc skiptest {{msg {}}} {
puts [format "%16s: --- skipped$msg" $::argv0]
exit 0
}
# If tcl, just use tcltest
if {[catch {info version}]} {
package require Tcl 8.5
package require tcltest 2.1
namespace import tcltest::*
if {$testinfo(verbose)} {
configure -verbose bps
}
testConstraint utf8 1
testConstraint tcl 1
proc testreport {} {
::tcltest::cleanupTests
}
return
}
lappend auto_path $testdir $bindir [file dirname [pwd]]
# For Jim, this is reasonable compatible tcltest
proc makeFile {contents name} {
set f [open $name w]
puts $f $contents
close $f
return $name
}
proc removeFile {name} {
file delete $name
}
proc script_source {script} {
lassign [info source $script] f l
if {$f ne ""} {
puts "At : $f:$l"
return \t$f:$l
}
}
proc error_source {} {
lassign [info stacktrace] p f l
if {$f ne ""} {
puts "At : $f:$l"
return \t$f:$l
}
}
proc package-or-skip {name} {
if {[catch {
package require $name
}]} {
puts [format "%16s: --- skipped" $::argv0]
exit 0
}
}
proc testConstraint {constraint bool} {
set ::tcltest::testConstraints($constraint) $bool
}
testConstraint {utf8} [expr {[string length "\xc2\xb5"] == 1}]
testConstraint {references} [expr {[info commands ref] ne ""}]
testConstraint {jim} 1
testConstraint {tcl} 0
proc bytestring {x} {
return $x
}
# Note: We don't support -output or -errorOutput yet
proc test {id descr args} {
set a [dict create -returnCodes {ok return} -match exact -result {} -constraints {} -body {} -setup {} -cleanup {}]
if {[lindex $args 0] ni [dict keys $a]} {
if {[llength $args] == 2} {
lassign $args body result constraints
} elseif {[llength $args] == 3} {
lassign $args constraints body result
} else {
return -code error "$id: Wrong syntax for tcltest::test v1"
}
tailcall test $id $descr -body $body -result $result -constraints $constraints
}
# tcltest::test v2 syntax
array set a $args
incr ::testinfo(numtests)
if {$::testinfo(verbose)} {
puts -nonewline "$id "
}
foreach c $a(-constraints) {
if {[info exists ::tcltest::testConstraints($c)]} {
if {$::tcltest::testConstraints($c)} {
continue
}
incr ::testinfo(numskip)
if {$::testinfo(verbose)} {
puts "SKIP"
}
return
}
}
catch {uplevel 1 $a(-setup)}
set rc [catch {uplevel 1 $a(-body)} result opts]
catch {uplevel 1 $a(-cleanup)}
if {[info return $rc] ni $a(-returnCodes) && $rc ni $a(-returnCodes)} {
set ok 0
set expected "rc=$a(-returnCodes) result=$a(-result)"
set result "rc=[info return $rc] result=$result"
} else {
if {$a(-match) eq "exact"} {
set ok [string equal $a(-result) $result]
} elseif {$a(-match) eq "glob"} {
set ok [string match $a(-result) $result]
} elseif {$a(-match) eq "regexp"} {
set ok [regexp $a(-result) $result]
} else {
return -code error "$id: unknown match type: $a(-match)"
}
set expected $a(-result)
}
if {$ok} {
if {$::testinfo(verbose)} {
puts "OK $descr"
}
incr ::testinfo(numpass)
return
}
if {!$::testinfo(verbose)} {
puts -nonewline "$id "
}
puts "ERR $descr"
if {$rc in {0 2}} {
set source [script_source $a(-body)]
} else {
set source [error_source]
}
puts "Expected: '$expected'"
puts "Got : '$result'"
puts ""
incr ::testinfo(numfail)
lappend ::testinfo(failed) [list $id $descr $source $expected $result]
}
proc ::tcltest::cleanupTests {} {
tailcall testreport
}
proc testreport {} {
if {$::testinfo(verbose)} {
puts -nonewline "\n$::argv0"
} else {
puts -nonewline [format "%16s" $::argv0]
}
puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \
$::testinfo(numtests) $::testinfo(numpass) $::testinfo(numskip) $::testinfo(numfail)]
if {$::testinfo(numfail)} {
puts [string repeat - 60]
puts "FAILED: $::testinfo(numfail)"
foreach failed $::testinfo(failed) {
foreach {id descr source expected result} $failed {}
puts "$source\t$id"
}
puts [string repeat - 60]
}
if {$::testinfo(numfail)} {
exit 1
}
}
proc testerror {} {
error "deliberate error"
}
if {$testinfo(verbose)} {
puts "==== $argv0 ===="
}

2
debuggers/openocd/jimtcl/tests/testio.in Normal file
View File

@ -0,0 +1,2 @@
One line here
^

454
debuggers/openocd/jimtcl/tests/timer.test Normal file
View File

@ -0,0 +1,454 @@
# This file contains a collection of tests for the procedures in the
# file tclTimer.c, which includes the "after" Tcl command. Sourcing
# this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: timer.test,v 1.7.2.1 2001/10/13 01:14:19 hobbs Exp $
source [file dirname [info script]]/testing.tcl
needs cmd after eventloop
test timer-1.1 {Tcl_CreateTimerHandler procedure} {
foreach i [after info] {
after cancel $i
}
set x ""
foreach i {20 40 200 10 30} {
after $i lappend x $i
}
after 50
update
set x
} {10 20 30 40}
test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
foreach i [after info] {
after cancel $i
}
set x ""
foreach i {20 40 60 10 30} {
after $i lappend x $i
}
after cancel lappend x 60
after cancel lappend x 10
after 50
update
set x
} {20 30 40}
# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
# above.
test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
set x start
after 20 { set x fired }
update idletasks
set result $x
after 40
update
lappend result $x
} {start fired}
test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} {
foreach i [after info] {
after cancel $i
}
foreach i {40 120 200} {
after $i lappend x $i
}
after 50
set result ""
set x ""
update
lappend result $x
after 80
update
lappend result $x
after 80
update
lappend result $x
} {40 {40 120} {40 120 200}}
test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
foreach i [after info] {
after cancel $i
}
set x {}
after 20 lappend x 20
set i [after 60 lappend x 60]
after 40 after cancel $i
after 80
update
set x
} 20
test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
foreach i [after info] {
after cancel $i
}
set x {}
after 20 lappend x a
after 40 lappend x b
after 60 lappend x c
after 70
vwait x
set x
} {a b c}
test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
foreach i [after info] {
after cancel $i
}
set x {}
after 20 {lappend x a; after 0 lappend x b}
after 20
vwait x
set x
} a
test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
foreach i [after info] {
after cancel $i
}
set x {}
after 20 {lappend x a; after 20 lappend x b; after 20}
after 20
vwait x
set result $x
vwait x
lappend result $x
} {a {a b}}
# No tests for Tcl_DoWhenIdle: it's already tested by other tests
# below.
test timer-4.1 {Tcl_CancelIdleCall procedure} {
foreach i [after info] {
after cancel $i
}
set x before
set y before
set z before
after idle set x after1
after idle set y after2
after idle set z after3
after cancel set y after2
update idletasks
concat $x $y $z
} {after1 before after3}
test timer-4.2 {Tcl_CancelIdleCall procedure} {
foreach i [after info] {
after cancel $i
}
set x before
set y before
set z before
after idle set x after1
after idle set y after2
after idle set z after3
after cancel set x after1
update idletasks
concat $x $y $z
} {before after2 after3}
test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} {
foreach i [after info] {
after cancel $i
}
set x 1
set y 23
after idle {incr x; after idle {incr x; after idle {incr x}}}
after idle {incr y}
vwait x
set result "$x $y"
update idletasks
lappend result $x
} {2 24 4}
test timer-6.1 {Tcl_AfterCmd procedure, basics} {
list [catch {after} msg] $msg
} {1 {wrong # args: should be "after option ?arg ...?"}}
test timer-6.2 {Tcl_AfterCmd procedure, basics} jim {
list [catch {after 2x} msg] $msg
} {1 {bad argument "2x": must be cancel, idle, or info}}
test timer-6.3 {Tcl_AfterCmd procedure, basics} jim {
list [catch {after gorp} msg] $msg
} {1 {bad argument "gorp": must be cancel, idle, or info}}
test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 80 {set x after}
after 40
update
set y $x
after 80
update
list $y $x
} {before after}
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 60 {set x after}
after 40
update
set y $x
after 40
update
list $y $x
} {before after}
test timer-6.6 {Tcl_AfterCmd procedure, cancel option} {
list [catch {after cancel} msg] $msg
} {1 {wrong # args: should be "after cancel id|command"}}
test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
after cancel after#1
} {}
test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
after cancel {foo bar}
} {}
test timer-6.9 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x before
set y [after 20 set x after]
after cancel $y
after 40
update
set x
} {before}
test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x before
after 20 set x after
after cancel set x after
after 40
update
set x
} {before}
test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x before
after 20 set x after
set id [after 60 set x after]
after cancel $id
after 40
update
set y $x
set x cleared
after 40
update
list $y $x
} {after cleared}
test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
foreach i [after info] {
after cancel $i
}
set x first
after idle lappend x second
after idle lappend x third
set i [after idle lappend x fourth]
after cancel {lappend x second}
after cancel $i
update idletasks
set x
} {first third}
test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} {
foreach i [after info] {
after cancel $i
}
set x first
after idle lappend x second
after idle lappend x third
set i [after idle lappend x fourth]
after cancel lappend x second
after cancel $i
update idletasks
set x
} {first third}
test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} {
foreach i [after info] {
after cancel $i
}
set id [
after 20 {
set x done
after cancel $id
}
]
vwait x
} {}
test timer-6.16 {Tcl_AfterCmd procedure, idle option} {
list [catch {after idle} msg] $msg
} {1 {wrong # args: should be "after idle script ?script ...?"}}
test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
set x before
after idle {set x after}
set y $x
update idletasks
list $y $x
} {before after}
test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
set x before
after idle set x after
set y $x
update idletasks
list $y $x
} {before after}
test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 "set x ab\0cd"
after 10
update
string length $x
} {5}
test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 set x ab\0cd
after 10
update
string length $x
} {5}
test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 set x ab\0cd
after cancel "set x ab\0ef"
set x [llength [after info]]
foreach i [after info] {
after cancel $i
}
set x
} {1}
test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after 1 set x ab\0cd
after cancel set x ab\0ef
set y [llength [after info]]
foreach i [after info] {
after cancel $i
}
set y
} {1}
test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after idle "set x ab\0cd"
update
string length $x
} {5}
test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
after idle set x ab\0cd
update
string length $x
} {5}
test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
foreach i [after info] {
after cancel $i
}
set x "hello world"
set id junk
set id [after 10 set x ab\0cd]
update
set y [string length [lindex [lindex [after info $id] 0] 2]]
foreach i [after info] {
after cancel $i
}
set y
} {5}
set event [after idle foo bar]
scan $event after#%d id
test timer-7.1 {GetAfterEvent procedure} {
list [catch {after info xfter#$id} msg] $msg
} "1 {event \"xfter#$id\" doesn't exist}"
test timer-7.2 {GetAfterEvent procedure} {
list [catch {after info afterx$id} msg] $msg
} "1 {event \"afterx$id\" doesn't exist}"
test timer-7.3 {GetAfterEvent procedure} {
list [catch {after info after#ab} msg] $msg
} {1 {event "after#ab" doesn't exist}}
test timer-7.4 {GetAfterEvent procedure} {
list [catch {after info after#} msg] $msg
} {1 {event "after#" doesn't exist}}
test timer-7.5 {GetAfterEvent procedure} {
list [catch {after info after#${id}x} msg] $msg
} "1 {event \"after#${id}x\" doesn't exist}"
test timer-7.6 {GetAfterEvent procedure} {
list [catch {after info afterx[expr $id+1]} msg] $msg
} "1 {event \"afterx[expr $id+1]\" doesn't exist}"
after cancel $event
test timer-8.1 {AfterProc procedure} {
set x before
proc foo {} {
set x untouched
after 20 {set x after}
after 200
update
return $x
}
list [foo] $x
} {untouched after}
test timer-8.2 {AfterProc procedure} {
catch {rename bgerror {}}
proc bgerror msg {
set ::x $msg
}
set x empty
after 20 {error "After error"}
after 200
set y $x
update
catch {rename bgerror {}}
list $y $x
} {empty {After error}}
test timer-8.4 {AfterProc procedure, deleting handler from itself} {
foreach i [after info] {
after cancel $i
}
proc foo {} {
global x
set x {}
foreach i [after info] {
lappend x [after info $i]
}
after cancel foo
}
after 1000 {error "I shouldn't ever have executed"}
after idle foo
update idletasks
set x
} {{{error "I shouldn't ever have executed"} timer}}
foreach i [after info] {
after cancel $i
}
testreport

115
debuggers/openocd/jimtcl/tests/tree.test Normal file
View File

@ -0,0 +1,115 @@
source [file dirname [info script]]/testing.tcl
needs cmd tree
needs cmd ref
proc dputs {msg} {
#puts $msg
}
test tree-1.1 "Create tree" {
set pt [tree]
return 1
} {1}
test tree-1.2 "Root node depth" {
$pt depth root
} {0}
test tree-1.3 "Access invalid node" {
list [catch {
$pt depth bogus
} msg] $msg
} {1 {key "bogus" not known in dictionary}}
test tree-1.4 "Set key/value" {
$pt set root key value
$pt set root type root
$pt set root name rootnode
$pt set root values {}
$pt get root key
} {value}
test tree-1.5 "Add child node" {
set n [$pt insert root]
$pt set $n childkey childvalue
$pt set $n type level1type
$pt set $n name childnode1
$pt set $n values {label testlabel}
$pt get $n childkey
} {childvalue}
test tree-1.6 "Add child, child node" {
set nn [$pt insert $n]
$pt set $nn childkey2 childvalue2
$pt set $nn type level2type
$pt set $nn name childnode2
$pt set $nn values {label testlabel storage none}
$pt get $nn childkey2
} {childvalue2}
test tree-1.7 "Key exists true" {
$pt keyexists $nn childkey2
} {1}
test tree-1.7 "Key exists false" {
$pt keyexists $n boguskey
} {0}
test tree-1.8 "lappend" {
$pt lappend $n newkey first
$pt lappend $n newkey second
$pt lappend $n newkey third
$pt lappend $n newkey last
} {first second third last}
test tree-2.0 "Add more nodes" {
set c [$pt insert root]
$pt set $c name root.c2
set c [$pt insert root]
$pt set $c name root.c3
set c [$pt insert $n]
$pt set $c name n.c4
set c [$pt insert $n]
$pt set $c name n.c5
set c [$pt insert $c]
$pt set $c name n.c5.c6
return 1
} {1}
test tree-2.1 "walk dfs" {
set result {}
dputs ""
$pt walk root dfs {action n} {
set indent [string repeat " " [$pt depth $n]]
if {$action == "enter"} {
lappend result [$pt get $n name]
dputs "$indent[$pt get $n name]"
}
}
dputs ""
set result
} {rootnode childnode1 childnode2 n.c4 n.c5 n.c5.c6 root.c2 root.c3}
test tree-2.2 "walk dfs exit" {
set result {}
$pt walk root dfs {action n} {
if {$action == "exit"} {
lappend result [$pt get $n name]
}
}
set result
} {childnode2 n.c4 n.c5.c6 n.c5 childnode1 root.c2 root.c3 rootnode}
test tree-2.3 "walk bfs" {
set result {}
$pt walk root bfs {action n} {
if {$action == "enter"} {
lappend result [$pt get $n name]
}
}
set result
} {rootnode childnode1 root.c2 root.c3 childnode2 n.c4 n.c5 n.c5.c6}
$pt destroy
testreport

117
debuggers/openocd/jimtcl/tests/try.test Normal file
View File

@ -0,0 +1,117 @@
source [file dirname [info script]]/testing.tcl
needs cmd try tclcompat
test try-1.1 "Simple case" {
try {
set x 0
} finally {
incr x
}
} 0
test try-1.2 "Error in body" {
list [catch {
try {
set x 0
error message
} finally {
incr x
}
} msg] $msg $x
} {1 message 1}
test try-1.3 "Error in finally" {
list [catch {
try {
set x 0
} finally {
incr x
error finally
}
} msg] $msg $x
} {1 finally 1}
test try-1.4 "Error in both" {
list [catch {
try {
set x 0
error message
} finally {
incr x
error finally
}
} msg] $msg $x
} {1 finally 1}
test try-1.5 "break in body" {
list [catch {
try {
set x 0
break
} finally {
incr x
}
} msg] $msg $x
} {3 {} 1}
test try-1.6 "break in finally" {
list [catch {
try {
set x 0
} finally {
incr x
break
}
} msg] $msg $x
} {3 {} 1}
test try-1.7 "return value from try, not finally" {
list [catch {
try {
set x 0
} finally {
incr x
}
} msg] $msg $x
} {0 0 1}
test try-1.8 "return from within try" {
proc a {} {
try {
return 1
}
# notreached
return 2
}
a
} {1}
test try-1.9 "return -code from within try" {
proc a {} {
try {
return -code break text
}
# notreached
return 2
}
list [catch a msg] $msg
} {3 text}
proc c {} {
try {
error here
} on error {msg opts} {
# jim can do simply:
if {[catch {incr opts(-level)}]} {
# Must be Tcl
dict incr opts -level
}
return {*}$opts $msg
}
}
test try-3.1 "rethrow error in try/on handler" {
list [catch c msg] $msg
} {1 here}
testreport

124
debuggers/openocd/jimtcl/tests/uplevel.test Normal file
View File

@ -0,0 +1,124 @@
# Commands covered: uplevel
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: uplevel.test,v 1.6 2000/04/10 17:19:05 ericm Exp $
source [file dirname [info script]]/testing.tcl
proc a {x y} {
newset z [expr $x+$y]
return $z
}
proc newset {name value} {
uplevel set $name $value
uplevel 1 {uplevel 1 {set xyz 22}}
}
proc b {x y} {
uplevel #0 set $x $y
}
test uplevel-1.1 {simple operation} {
set xyz 0
a 22 33
} 55
test uplevel-1.2 {command is another uplevel command} {
set xyz 0
a 22 33
set xyz
} 22
proc a1 {} {
b1
global a a1
set a $x
set a1 $y
}
proc b1 {} {
c1
global b b1
set b $x
set b1 $y
}
proc c1 {} {
uplevel 1 set x 111
uplevel #2 set y 222
uplevel 2 set x 333
uplevel #1 set y 444
uplevel 3 set x 555
uplevel #0 set y 666
}
a1
test uplevel-2.1 {relative and absolute uplevel} {set a} 333
test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
test uplevel-2.3 {relative and absolute uplevel} {set b} 111
test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
test uplevel-2.5 {relative and absolute uplevel} {set x} 555
test uplevel-2.6 {relative and absolute uplevel} {set y} 666
test uplevel-3.1 {uplevel to same level} {
set x 33
uplevel #0 set x 44
set x
} 44
test uplevel-3.2 {uplevel to same level} {
set x 33
uplevel 0 set x
} 33
test uplevel-3.3 {uplevel to same level} {
set y xxx
proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
a1
} 66
test uplevel-3.4 {uplevel to same level} {
set y zzz
proc a1 {} {set y 55; uplevel #1 set y}
a1
} 55
test uplevel-4.1 {error check: non-existent level} {
list [catch c1 msg] $msg
} {1 {bad level "#2"}}
test uplevel-4.2 {error check: non-existent level} {
proc c2 {} {uplevel 3 {set a b}}
list [catch c2 msg] $msg
} {1 {bad level "3"}}
test uplevel-4.3 {error check: not enough args} {
list [catch uplevel msg] $msg
} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
test uplevel-4.4 {error check: not enough args} {
proc upBug {} {uplevel 1}
list [catch upBug msg] $msg
} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
proc a2 {} {
uplevel a3
}
proc a3 {} {
global x y
set x [info level]
set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3
test uplevel-6.1 {uplevel #0} {
b g1 g1val
set ::g1
} g1val
test uplevel-6.2 {uplevel #bad} {
catch {uplevel #bad set x 1}
} 1
testreport

350
debuggers/openocd/jimtcl/tests/upvar.test Normal file
View File

@ -0,0 +1,350 @@
# Commands covered: upvar
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: upvar.test,v 1.7 2000/04/10 17:19:05 ericm Exp $
source [file dirname [info script]]/testing.tcl
needs cmd array
test upvar-1.1 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
test upvar-1.2 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {p3}
proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
p1 foo bar
} {foo bar 22 33 abc}
test upvar-1.3 {reading variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {p3}
proc p3 {} {
upvar #1 a x1 b x2 c x3 d x4
set a abc
list $x1 $x2 $x3 $x4 $a
}
p1 foo bar
} {foo bar 22 33 abc}
test upvar-1.4 {reading variables with upvar} {
set x1 44
set x2 55
proc p1 {} {p2}
proc p2 {} {
upvar 2 x1 x1 x2 a
upvar #0 x1 b
set c $b
incr b 3
list $x1 $a $b
}
p1
} {47 55 47}
test upvar-1.5 {reading array elements with upvar} {
proc p1 {} {set a(0) zeroth; set a(1) first; p2}
proc p2 {} {upvar a(0) x; set x}
p1
} {zeroth}
test upvar-2.1 {writing variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
proc p2 {} {
upvar a x1 b x2 c x3 d x4
set x1 14
set x4 88
}
p1 foo bar
} {14 bar 22 88}
test upvar-2.2 {writing variables with upvar} {
set x1 44
set x2 55
proc p1 {x1 x2} {
upvar #0 x1 a
upvar x2 b
set a $x1
set b $x2
}
p1 newbits morebits
list $x1 $x2
} {newbits morebits}
test upvar-2.3 {writing variables with upvar} {
catch {unset x1}
catch {unset x2}
proc p1 {x1 x2} {
upvar #0 x1 a
upvar x2 b
set a $x1
set b $x2
}
p1 newbits morebits
list [catch {set x1} msg] $msg [catch {set x2} msg] $msg
} {0 newbits 0 morebits}
test upvar-2.4 {writing array elements with upvar} {
proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)}
proc p2 {} {upvar a(0) x; set x xyzzy}
p1
} {xyzzy xyzzy}
test upvar-3.1 {unsetting variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
proc p2 {} {
upvar 1 a x1 d x2
unset x1 x2
}
p1 foo bar
} {b c}
test upvar-3.2 {unsetting variables with upvar} {
proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
proc p2 {} {
upvar 1 a x1 d x2
unset x1 x2
set x2 28
}
p1 foo bar
} {b c d}
test upvar-3.3 {unsetting variables with upvar} {
set x1 44
set x2 55
proc p1 {} {p2}
proc p2 {} {
upvar 2 x1 a
upvar #0 x2 b
unset a b
}
p1
list [info exists x1] [info exists x2]
} {0 0}
test upvar-3.4 {unsetting variables with upvar} {
set x1 44
set x2 55
proc p1 {} {
upvar x1 a x2 b
unset a b
set b 118
}
p1
list [info exists x1] [catch {set x2} msg] $msg
} {0 0 118}
test upvar-3.5 {unsetting array elements with upvar} {
proc p1 {} {
set a(0) zeroth
set a(1) first
set a(2) second
p2
array names a
}
proc p2 {} {upvar a(0) x; unset x}
p1
} {1 2}
test upvar-3.6 {unsetting then resetting array elements with upvar} {
proc p1 {} {
set a(0) zeroth
set a(1) first
set a(2) second
p2
list [array names a] [catch {set a(0)} msg] $msg
}
proc p2 {} {upvar a(0) x; unset x; set x 12345}
p1
} {{0 1 2} 0 12345}
test upvar-4.1 {nested upvars} {
set x1 88
proc p1 {a b} {set c 22; set d 33; p2}
proc p2 {} {global x1; upvar c x2; p3}
proc p3 {} {
upvar x1 a x2 b
list $a $b
}
p1 14 15
} {88 22}
test upvar-4.2 {nested upvars} {
set x1 88
proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
proc p2 {} {global x1; upvar c x2; p3}
proc p3 {} {
upvar x1 a x2 b
set a foo
set b bar
}
list [p1 14 15] $x1
} {{14 15 bar 33} foo}
proc tproc {args} {global x; set x [list $args [uplevel info vars]]}
test upvar-6.1 {retargeting an upvar} {
proc p1 {} {
set a(0) zeroth
set a(1) first
set a(2) second
p2
}
proc p2 {} {
upvar a x
set result {}
foreach i [array names x] {
upvar a($i) x
lappend result $x
}
lsort $result
}
p1
} {first second zeroth}
test upvar-6.2 {retargeting an upvar} {
set x 44
set y abcde
proc p1 {} {
global x
set result $x
upvar y x
lappend result $x
}
p1
} {44 abcde}
test upvar-6.3 {retargeting an upvar} {
set x 44
set y abcde
proc p1 {} {
upvar y x
lappend result $x
global x
lappend result $x
}
p1
} {abcde 44}
test upvar-7.1 {upvar to same level} {
set x 44
set y 55
catch {unset uv}
upvar #0 x uv
set uv abc
upvar 0 y uv
set uv xyzzy
list $x $y
} {abc xyzzy}
test upvar-7.2 {upvar to same level} {
set x 1234
set y 4567
proc p1 {x y} {
upvar 0 x uv
set uv $y
return "$x $y"
}
p1 44 89
} {89 89}
test upvar-7.3 {upvar to same level} {
set x 1234
set y 4567
proc p1 {x y} {
upvar #1 x uv
set uv $y
return "$x $y"
}
p1 xyz abc
} {abc abc}
test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} {
proc tt {} {upvar #1 toto loc; return $loc}
list [catch tt msg] $msg
} {1 {can't read "loc": no such variable}}
test upvar-7.5 {potential memory leak when deleting variable table} {
proc leak {} {
array set foo {1 2 3 4}
upvar 0 foo(1) bar
}
leak
} {}
test upvar-8.1 {errors in upvar command} {
catch upvar msg
} 1
test upvar-8.2 {errors in upvar command} {
catch {upvar 1}
} 1
test upvar-8.3 {errors in upvar command} {
proc p1 {} {upvar a b c}
catch p1
} 1
test upvar-8.4 {errors in upvar command} {
proc p1 {} {upvar 0 b b}
list [catch p1 msg] $msg
} {1 {can't upvar from variable to itself}}
test upvar-8.5 {errors in upvar command} {
proc p1 {} {upvar 0 a b; upvar 0 b a}
list [catch p1 msg] $msg
} {1 {can't upvar from variable to itself}}
test upvar-8.6 {errors in upvar command} {
proc p1 {} {set a 33; upvar b a}
list [catch p1 msg] $msg
} {1 {variable "a" already exists}}
# Jim allows dicts within dicts. Tcl can't do this.
test upvar-8.8 {create nested array with upvar} jim {
proc p1 {} {upvar x(a) b; set b(2) 44}
catch {unset x}
p1
set x
} {a {2 44}}
test upvar-8.10 {upvar will create element alias for new array element} {
catch {unset upvarArray}
array set upvarArray {}
catch {upvar 0 upvarArray(elem) upvarArrayElemAlias}
} {0}
test upvar-8.11 {error upvar array element} {
proc a {} { upvar a b(1) }
list [catch {a} msg] $msg
} {1 {bad variable name "b(1)": upvar won't create a scalar variable that looks like an array element}}
test upvar-9.1 {global redefine} {
proc p1 {} { global x; global x }
p1
} {}
test upvar-9.2 {upvar redefine} {
set a 1
set b 2
proc p1 {} { upvar a x; upvar b x; return $x }
p1
} 2
test upvar-9.3 {upvar redefine static} jim {
proc p1 {} {{a 3}} { upvar b a; return $b }
list [catch p1 msg] $msg
} {1 {variable "a" already exists}}
test upvar-9.4 {upvar links to static} jim {
proc p1 {} {} { upvar a x; incr x; return $x }
proc p2 {} {{a 3}} { list [p1] $a }
p2
} {4 4}
test upvar-9.5 {upvar via global namespace} {
set x 2
unset -nocomplain y
# Links ::y to ::x
proc p1 {} { upvar x ::y; incr ::y -1 }
p1
list $x $y
} {1 1}
test upvar-9.6 {upvar via global namespace} {
set x 2
unset -nocomplain x
# Links ::x to ::x
proc p1 {} { upvar x ::x; incr ::x }
list [catch p1 msg] $msg
} {1 {can't upvar from variable to itself}}
test upvar-9.7 {upvar to higher level} {
proc p1 {} { upvar 0 x ::globx }
list [catch p1 msg] $msg
} {1 {bad variable name "::globx": upvar won't create namespace variable that refers to procedure variable}}
catch {unset a}
testreport

152
debuggers/openocd/jimtcl/tests/utf8.test Normal file
View File

@ -0,0 +1,152 @@
source [file dirname [info script]]/testing.tcl
needs constraint utf8
test utf8-1.1 "Pattern matching - ?" {
string match "abc?def" "abc\u00b5def"
} 1
test utf8-1.2 "Pattern matching - ?" {
string match "abc?def" "abc\u2704def"
} 1
test utf8-1.3 "Pattern utf-8 literal" {
string match "ab\u00b5\u2704?" "ab\u00b5\u2704x"
} 1
test utf8-1.4 "Pattern utf-8 char sets" {
string match "a\[b\u00b5\]\u2704?" "a\u00b5\u2704x"
} 1
test utf8-1.5 "Pattern utf-8 char sets" {
string match "a\[b\u00b5\]\u2704?" "a\u00b6\u2704x"
} 0
test utf8-1.6 "Pattern utf-8 char sets" {
string match "a\[b\u00b5\]\u2704?" "ab\u2704x"
} 1
test utf8-1.7 "Pattern utf-8 char sets" {
string match "a\[b\u00b5\]?" "a\u2704x"
} 0
test utf8-1.8 "Pattern utf-8 char sets" {
string match "a\[\u00b5-\u00c3\]" "a\ubd"
} 1
test utf8-1.9 "Pattern utf-8 char sets" {
string match "a\[\u00b5-\u00c3\]" "a\uc4"
} 0
test utf8-2.1 "Pattern utf-8 nocase" {
string match -nocase "a\u1edc\u1ef4*" "A\u1edd\u1ef5XX"
} 1
test utf8-2.2 "Pattern utf-8 case difference" {
string match "a\u1edc\u1ef4*" "A\u1edd\u1ef5XX"
} 0
test utf8-3.1 "lsearch -glob" {
lsearch -glob {1 d a\u00b5xyb c} a\ub5*b
} 2
test utf8-3.2 "switch -glob" {
switch -glob -- a\ub5xyb a\ub5*b { set x 1 } default { set x 0 }
set x
} 1
set x "\ub5test"
test utf8-3.3 "info procs" {
proc $x {} { info procs \[\ub5X]???? }
$x
} $x
test utf8-3.3 "info commands" {
info commands \[\ub5X]????
} $x
test utf8-3.4 "proc name with invalid utf-8" {
catch { proc ab\xc2 {} {} } msg
} 0
test utf8-3.5 "rename to invalid name" {
catch { rename ab\xc2 ab\xc3 } msg
} 0
catch {rename ab\xc3 ""}
test utf8-4.1 "split with utf-8" {
split "zy\u2702xw" x
} "zy\u2702 w"
test utf8-4.2 "split with utf-8" {
split "zy\u2702xw" \u2702
} "zy xw"
test utf8-4.2 "split with utf-8" {
split "zy\u2702xw" {}
} "z y \u2702 x w"
test utf8-5.1 "string first with utf-8" {
string first w "zy\u2702xw"
} 4
test utf8-5.2 "string first with utf-8" {
string first \u2702 "\ub5zy\u2702xw"
} 3
test utf8-5.3 "string first with utf-8" {
string first \u2704 "\ub5zy\u2702xw"
} -1
test utf8-5.4 "string first with utf-8" {
string first \u2702 "\ub5zy\u2702xw\u2702BB"
} 3
test utf8-6.1 "string last with utf-8" {
string last w "zy\u2702xw"
} 4
test utf8-6.2 "string last with utf-8" {
string last \u2702 "\ub5zy\u2702xw"
} 3
test utf8-6.3 "string last with utf-8" {
string last \u2704 "\ub5zy\u2702xw"
} -1
test utf8-6.4 "string last with utf-8" {
string last \u2702 "\ub5zy\u2702xw\u2702BB"
} 6
test utf8-7.1 "string reverse" {
string reverse \ub5Test\u2702
} \u2702tseT\ub5
test utf8-7.2 {append counts correctly} {
set x \u2702XYZ
append x \u2702XYZ
list [string length $x] [string bytelength $x]
} {8 12}
test utf8-7.3 {Upper, lower for titlecase utf-8} {
list [string toupper \u01c5] [string tolower \u01c5]
} "\u01c4 \u01c6"
test utf8-7.4 {Case folding may change encoded length} {
list [string bytelength \u0131] [string bytelength [string toupper \u0131]]
} {2 1}
test utf8-8.1 {Chars outside the BMP} jim {
string length \u{12000}\u{13000}
} 2
test utf8-8.2 {Chars outside the BMP} jim {
string match "ab\[\u{12000}c\]d" ab\u{12000}d
} 1
test utf8-8.3 {Chars outside the BMP} jim {
string last d "ab\u{101fff}cd"
} 4
test utf8-8.4 {Longer sequences} {
string length \u12000
} 2
testreport

289
debuggers/openocd/jimtcl/tests/utftcl.test Normal file
View File

@ -0,0 +1,289 @@
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: utf.test,v 1.14 2007/05/02 01:37:28 kennykb Exp $
source [file dirname [info script]]/testing.tcl
needs constraint utf8
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\u80"
} [bytestring "\xc2\x80"]
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\ue0"
} [bytestring "\xc3\xa0"]
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
set x "\u4e4e"
} [bytestring "\xe4\xb9\x8e"]
test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
string length [format %c -1]
} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} {3}
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
string length [bytestring "\x82\x83\x84"]
} {3}
test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} {
string length [bytestring "\xC2"]
} {1}
test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
string length [bytestring "\xC2\xa2"]
} {1}
test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} {
string length [bytestring "\xE2"]
} {1}
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} {
string length [bytestring "\xE2\xA2"]
} {2}
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} {
string length [bytestring "\xE4\xb9\x8e"]
} {1}
# Note that Tcl may or may not support utf-8 sequences >= 4 bytes
test utf-2.9 {Tcl_UtfToUniChar: 4-byte UTF sequence} {
string length [bytestring "\xF4\xA2\xA2\xA2"]
} {1}
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
proc testnumutfchars {a {n ""}} {
string length $a
}
test utf-4.1 {Tcl_NumUtfChars: zero length} {
testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} {
testnumutfchars [bytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} {
testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
} {7}
test utf-4.4 {Tcl_NumUtfChars: #u0000} {
testnumutfchars [bytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} {
testnumutfchars "" 1
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {
testnumutfchars [bytestring "\xC2\xA2"] 1
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {
testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {
testnumutfchars [bytestring "\xC0\x80"] 1
} {1}
test utf-5.1 {Tcl_UtfFindFirsts} {
} {}
test utf-6.1 {Tcl_UtfNext} {
} {}
test utf-7.1 {Tcl_UtfPrev} {
} {}
test utf-8.1 {Tcl_UniCharAtIndex: index = 0} {
string index abcd 0
} {a}
test utf-8.2 {Tcl_UniCharAtIndex: index = 0} {
string index \u4e4e\u25a 0
} "\u4e4e"
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} {c}
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4e4e\u25a\uff\u543 2
} "\uff"
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} {abc}
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4e4e\u25a\xff\u543klmnop 1 5
} "\u25a\xff\u543kl"
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
test utf-10.2 {Tcl_UtfBackslash: \u subst} {
set x \ua2
} [bytestring "\xc2\xa2"]
test utf-10.3 {Tcl_UtfBackslash: longer \u subst} {
set x \u4e21
} [bytestring "\xe4\xb8\xa1"]
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} {
set x \u4e2k
} "[bytestring \xd3\xa2]k"
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} {
set x \u4e216
} "[bytestring \xe4\xb8\xa1]6"
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 6
bsCheck \b 8
bsCheck \e 101
bsCheck \f 12
bsCheck \n 10
bsCheck \r 13
bsCheck \t 9
bsCheck \v 11
bsCheck \{ 123
bsCheck \} 125
bsCheck \[ 91
bsCheck \] 93
bsCheck \$ 36
bsCheck \ 32
bsCheck \; 59
bsCheck \\ 92
bsCheck \Ca 67
bsCheck \Ma 77
bsCheck \CMa 67
# prior to 8.3, this returned 8, as \8 as accepted as an
# octal value - but it isn't! [Bug: 3975]
bsCheck \8a 56
bsCheck \14 12
bsCheck \141 97
bsCheck b\0 98
bsCheck \x 120
bsCheck \ua 10
bsCheck \uA 10
bsCheck \u41 65
bsCheck \u 117
bsCheck \uk 117
bsCheck \u41 65
bsCheck \ua 10
bsCheck \uA 10
bsCheck \340 224
bsCheck \ua1 161
bsCheck \u4e21 20001
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
} {}
test utf-11.2 {Tcl_UtfToUpper} {
string toupper abc
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
string toupper \u00e3ab
} \u00c3AB
test utf-11.4 {Tcl_UtfToUpper} {
string toupper \u01e3ab
} \u01e2AB
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower \u00c3AB
} \u00e3ab
test utf-12.4 {Tcl_UtfToLower} {
string tolower \u01e2AB
} \u01e3ab
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
string compare -nocase b a
} 1
test utf-14.3 {Tcl_UtfNcasecmp} {
string compare -nocase B a
} 1
test utf-14.4 {Tcl_UtfNcasecmp} {
string compare -nocase aBcB abca
} 1
test utf-15.1 {Tcl_UniCharToUpper, negative delta} {
string toupper aA
} AA
test utf-15.2 {Tcl_UniCharToUpper, positive delta} {
string toupper \u0178\u00ff
} \u0178\u0178
test utf-15.3 {Tcl_UniCharToUpper, no delta} {
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
string tolower \u0178\u00ff
} \u00ff\u00ff
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !
} !
#test utf-21.1 {TclUniCharIsAlnum} {
# # this returns 1 with Unicode 3 compliance
# string is alnum \u1040\u021f
#} {1}
#test utf-21.2 {unicode alnum char in regc_locale.c} {
# # this returns 1 with Unicode 3 compliance
# list [regexp {^[[:alnum:]]+$} \u1040\u021f] [regexp {^\w+$} \u1040\u021f]
#} {1 1}
#test utf-22.1 {TclUniCharIsWordChar} {
# string wordend "xyz123_bar fg" 0
#} 10
#test utf-22.2 {TclUniCharIsWordChar} {
# string wordend "x\u5080z123_bar\u203c fg" 0
#} 10
#test utf-23.1 {TclUniCharIsAlpha} {
# # this returns 1 with Unicode 3 compliance
# string is alpha \u021f
#} {1}
#test utf-23.2 {unicode alpha char in regc_locale.c} {
# # this returns 1 with Unicode 3 compliance
# regexp {^[[:alpha:]]+$} \u021f
#} {1}
#
#test utf-24.1 {TclUniCharIsDigit} {
# # this returns 1 with Unicode 3 compliance
# string is digit \u1040
#} {1}
#test utf-24.2 {unicode digit char in regc_locale.c} {
# # this returns 1 with Unicode 3 compliance
# list [regexp {^[[:digit:]]+$} \u1040] [regexp {^\d+$} \u1040]
#} {1 1}
#
#test utf-24.3 {TclUniCharIsSpace} {
# # this returns 1 with Unicode 3 compliance
# string is space \u1680
#} {1}
#test utf-24.4 {unicode space char in regc_locale.c} {
# # this returns 1 with Unicode 3 compliance
# list [regexp {^[[:space:]]+$} \u1680] [regexp {^\s+$} \u1680]
#} {1 1}
testreport

481
debuggers/openocd/jimtcl/tests/util.test Normal file
View File

@ -0,0 +1,481 @@
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
source [file dirname [info script]]/testing.tcl
needs cmd binary
testConstraint controversialNaN 1
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
# Big test for correct ordering of data in [expr]
proc convertDouble { x } {
variable ieeeValues
if { $ieeeValues(littleEndian) } {
binary scan [binary format w $x] d result
} else {
binary scan [binary format W $x] d result
}
return $result
}
test util-1.1 {TclFindElement procedure - binary element in middle of list} {
lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
lindex {0 foo\x00help} 1
} "foo\x00help"
test util-2.1 {TclCopyAndCollapse procedure - normal string} {
lindex {0 foo} 1
} {foo}
test util-2.2 {TclCopyAndCollapse procedure - string with backslashes} {
lindex {0 foo\n\x00help 1} 1
} "foo\n\x00help"
test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces} {
# This test checks for a very tricky feature. Any list element
# generated with Tcl_ScanCountedElement and Tcl_ConvertElement must
# have the property that it can be enclosing in curly braces to make
# an embedded sub-list. If this property doesn't hold, then
# Tcl_DStringStartSublist doesn't work.
set x {}
lappend x "# \\\{ \\"
concat $x [llength "{$x}"]
} {\#\ \\\{\ \\ 1}
test util-3.2 {Tcl_ConverCountedElement procedure - quote leading '#'} {
list # # a
} {{#} # a}
test util-3.3 {Tcl_ConverCountedElement procedure - quote leading '#'} {
list #\{ # a
} {\#\{ # a}
test util-3.4 {Tcl_ConverCountedElement procedure - quote leading '#'} {
proc # {} {return #}
set result [eval [list #]]
rename # {}
set result
} {#}
test util-3.4.1 {Tcl_ConverCountedElement procedure - quote leading '#'} {
proc # {} {return #}
set cmd [list #]
append cmd "" ;# force string rep generation
set result [eval $cmd]
rename # {}
set result
} {#}
test util-3.5 {Tcl_ConverCountedElement procedure - quote leading '#'} {
proc #\{ {} {return #}
set result [eval [list #\{]]
rename #\{ {}
set result
} {#}
test util-3.5.1 {Tcl_ConverCountedElement procedure - quote leading '#'} {
proc #\{ {} {return #}
set cmd [list #\{]
append cmd "" ;# force string rep generation
set result [eval $cmd]
rename #\{ {}
set result
} {#}
test util-3.6 {Tcl_ConvertElement, Bug 3371644} tcl {
interp create #\\
interp alias {} x #\\ concat
interp target {} x ;# Crash if bug not fixed
interp delete #\\
} {}
test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b\ } c
} {a b\ c}
test util-4.2 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b\ } c
} {a b\ c}
test util-4.3 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b\\ } c
} {a b\\ c}
test util-4.4 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a {b } c
} {a b c}
test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a { } c
} {a c}
test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} {
# Check for Bug #227512. If this violates C isspace, then it returns \xc3.
concat \xe0
} \xe0
test util-4.7 {Tcl_ConcatObj - refCount safety} testconcatobj {
# Check for Bug #1447328 (actually, bugs in its original "fix"). One of the
# symptoms was Bug #2055782.
testconcatobj
} {}
proc Wrapper_Tcl_StringMatch {pattern string} {
# Forces use of Tcl_StringMatch, not Tcl_UniCharCaseMatch
switch -glob -- $string $pattern {return 1} default {return 0}
}
test util-5.1 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch ab*c abc
} 1
test util-5.2 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch ab**c abc
} 1
test util-5.3 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch ab* abcdef
} 1
test util-5.4 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *c abc
} 1
test util-5.5 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *3*6*9 0123456789
} 1
test util-5.6 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *3*6*9 01234567890
} 0
test util-5.7 {Tcl_StringMatch: UTF-8} {
Wrapper_Tcl_StringMatch *u \u4e4fu
} 1
test util-5.8 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch a?c abc
} 1
test util-5.9 {Tcl_StringMatch: UTF-8} utf8 {
# skip one character in string
Wrapper_Tcl_StringMatch a?c a\u4e4fc
} 1
test util-5.10 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch a??c abc
} 0
test util-5.11 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch ?1??4???8? 0123456789
} 1
test util-5.12 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {[abc]bc} abc
} 1
test util-5.13 {Tcl_StringMatch: UTF-8} utf8 {
# string += Tcl_UtfToUniChar(string, &ch);
Wrapper_Tcl_StringMatch "\[\u4e4fxy\]bc" "\u4e4fbc"
} 1
test util-5.14 {Tcl_StringMatch} {
# if ((*pattern == ']') || (*pattern == '\0'))
# badly formed pattern
Wrapper_Tcl_StringMatch {[]} {[]}
} 0
test util-5.15 {Tcl_StringMatch} {
# if ((*pattern == ']') || (*pattern == '\0'))
# badly formed pattern
Wrapper_Tcl_StringMatch {[} {[}
} 0
test util-5.16 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {a[abc]c} abc
} 1
test util-5.17 {Tcl_StringMatch: UTF-8} utf8 {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance.
Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc"
} 1
test util-5.20 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {a[xyz]c} abc
} 0
test util-5.21 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[2-7]45} 12345
} 1
test util-5.22 {Tcl_StringMatch: UTF-8 range} {
Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "0"
} 0
test util-5.23 {Tcl_StringMatch: UTF-8 range} utf8 {
Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\u4e33"
} 1
test util-5.24 {Tcl_StringMatch: UTF-8 range} utf8 {
Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\uff08"
} 0
test util-5.25 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12345
} 1
test util-5.26 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12b45
} 1
test util-5.27 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12d45
} 1
test util-5.28 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12145
} 0
test util-5.29 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12545
} 0
test util-5.30 {Tcl_StringMatch: forwards range} {
Wrapper_Tcl_StringMatch {[k-w]} "z"
} 0
test util-5.31 {Tcl_StringMatch: forwards range} {
Wrapper_Tcl_StringMatch {[k-w]} "w"
} 1
test util-5.32 {Tcl_StringMatch: forwards range} {
Wrapper_Tcl_StringMatch {[k-w]} "r"
} 1
test util-5.33 {Tcl_StringMatch: forwards range} {
Wrapper_Tcl_StringMatch {[k-w]} "k"
} 1
test util-5.34 {Tcl_StringMatch: forwards range} {
Wrapper_Tcl_StringMatch {[k-w]} "a"
} 0
test util-5.35 {Tcl_StringMatch: reverse range} {
Wrapper_Tcl_StringMatch {[w-k]} "z"
} 0
test util-5.36 {Tcl_StringMatch: reverse range} {
Wrapper_Tcl_StringMatch {[w-k]} "w"
} 1
test util-5.37 {Tcl_StringMatch: reverse range} {
Wrapper_Tcl_StringMatch {[w-k]} "r"
} 1
test util-5.38 {Tcl_StringMatch: reverse range} {
Wrapper_Tcl_StringMatch {[w-k]} "k"
} 1
test util-5.39 {Tcl_StringMatch: reverse range} {
Wrapper_Tcl_StringMatch {[w-k]} "a"
} 0
test util-5.40 {Tcl_StringMatch: skip correct number of ']'} {
Wrapper_Tcl_StringMatch {[A-]x} Ax
} 0
test util-5.41 {Tcl_StringMatch: skip correct number of ']'} {
Wrapper_Tcl_StringMatch {[A-]]x} Ax
} 1
test util-5.42 {Tcl_StringMatch: skip correct number of ']'} {
Wrapper_Tcl_StringMatch {[A-]]x} \ue1x
} 0
test util-5.43 {Tcl_StringMatch: skip correct number of ']'} utf8 {
Wrapper_Tcl_StringMatch \[A-]\ue1]x \ue1x
} 1
test util-5.44 {Tcl_StringMatch: skip correct number of ']'} {
Wrapper_Tcl_StringMatch {[A-]h]x} hx
} 1
test util-5.45 {Tcl_StringMatch} {
# if (*pattern == '\0')
# badly formed pattern, still treats as a set
Wrapper_Tcl_StringMatch {[a} a
} 1
test util-5.46 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {a\*b} a*b
} 1
test util-5.47 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {a\*b} ab
} 0
test util-5.48 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch {a\*\?\[\]\\\x} "a*?\[\]\\x"
} 1
test util-5.49 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch ** ""
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-9.0.0 {TclGetIntForIndex} {
string index abcd 0
} a
test util-9.0.1 {TclGetIntForIndex} {
string index abcd 0x0
} a
test util-9.0.2 {TclGetIntForIndex} {
string index abcd -0x0
} a
test util-9.0.3 {TclGetIntForIndex} {
string index abcd { 0 }
} a
test util-9.0.4 {TclGetIntForIndex} {
string index abcd { 0x0 }
} a
test util-9.0.5 {TclGetIntForIndex} {
string index abcd { -0x0 }
} a
test util-9.0.6 {TclGetIntForIndex} {
string index abcd 01
} b
test util-9.0.7 {TclGetIntForIndex} {
string index abcd { 01 }
} b
test util-9.1.0 {TclGetIntForIndex} {
string index abcd 3
} d
test util-9.1.1 {TclGetIntForIndex} {
string index abcd { 3 }
} d
test util-9.1.2 {TclGetIntForIndex} {
string index abcdefghijk 0xa
} k
test util-9.1.3 {TclGetIntForIndex} {
string index abcdefghijk { 0xa }
} k
test util-9.2.0 {TclGetIntForIndex} {
string index abcd end
} d
test util-9.2.1 {TclGetIntForIndex} -body {
string index abcd { end}
} -returnCodes error -match glob -result *
test util-9.2.2 {TclGetIntForIndex} -constraints tcl -body {
string index abcd {end }
} -returnCodes error -match glob -result *
test util-9.3 {TclGetIntForIndex} tcl {
# Deprecated
string index abcd en
} d
test util-9.4 {TclGetIntForIndex} tcl {
# Deprecated
string index abcd e
} d
test util-9.5.0 {TclGetIntForIndex} {
string index abcd end-1
} c
test util-9.5.1 {TclGetIntForIndex} tcl {
string index abcd {end-1 }
} c
test util-9.5.2 {TclGetIntForIndex} -body {
string index abcd { end-1}
} -returnCodes error -match glob -result *
test util-9.6 {TclGetIntForIndex} {
string index abcd end+-1
} c
test util-9.7 {TclGetIntForIndex} {
string index abcd end+1
} {}
test util-9.8 {TclGetIntForIndex} {
string index abcd end--1
} {}
test util-9.9.0 {TclGetIntForIndex} {
string index abcd 0+0
} a
test util-9.9.1 {TclGetIntForIndex} tcl {
string index abcd { 0+0 }
} a
test util-9.10 {TclGetIntForIndex} {
string index abcd 0-0
} a
test util-9.11 {TclGetIntForIndex} {
string index abcd 1+0
} b
test util-9.12 {TclGetIntForIndex} {
string index abcd 1-0
} b
test util-9.13 {TclGetIntForIndex} {
string index abcd 1+1
} c
test util-9.14 {TclGetIntForIndex} {
string index abcd 1-1
} a
test util-9.15 {TclGetIntForIndex} {
string index abcd -1+2
} b
test util-9.16 {TclGetIntForIndex} {
string index abcd -1--2
} b
test util-9.17 {TclGetIntForIndex} tcl {
string index abcd { -1+2 }
} b
test util-9.18 {TclGetIntForIndex} tcl {
string index abcd { -1--2 }
} b
test util-9.19 {TclGetIntForIndex} -body {
string index a {}
} -returnCodes error -match glob -result *
test util-9.20 {TclGetIntForIndex} -body {
string index a { }
} -returnCodes error -match glob -result *
test util-9.21 {TclGetIntForIndex} -body {
string index a " \r\t\n"
} -returnCodes error -match glob -result *
test util-9.22 {TclGetIntForIndex} -body {
string index a +
} -returnCodes error -match glob -result *
test util-9.23 {TclGetIntForIndex} -body {
string index a -
} -returnCodes error -match glob -result *
test util-9.24 {TclGetIntForIndex} -body {
string index a x
} -returnCodes error -match glob -result *
test util-9.25 {TclGetIntForIndex} -body {
string index a +x
} -returnCodes error -match glob -result *
test util-9.26 {TclGetIntForIndex} -body {
string index a -x
} -returnCodes error -match glob -result *
test util-9.27 {TclGetIntForIndex} -body {
string index a 0y
} -returnCodes error -match glob -result *
test util-9.28 {TclGetIntForIndex} -body {
string index a 1*
} -returnCodes error -match glob -result *
test util-9.29 {TclGetIntForIndex} -body {
string index a 0+
} -returnCodes error -match glob -result *
test util-9.30 {TclGetIntForIndex} -body {
string index a {0+ }
} -returnCodes error -match glob -result *
test util-9.31 {TclGetIntForIndex} -body {
string index a 0x
} -returnCodes error -match glob -result *
test util-9.32 {TclGetIntForIndex} -constraints tcl -body {
string index a 0x1FFFFFFFF+0
} -returnCodes error -match glob -result *
test util-9.33 {TclGetIntForIndex} -constraints tcl -body {
string index a 100000000000+0
} -returnCodes error -match glob -result *
test util-9.34 {TclGetIntForIndex} -body {
string index a 1.0
} -returnCodes error -match glob -result *
test util-9.35 {TclGetIntForIndex} -body {
string index a 1e23
} -returnCodes error -match glob -result *
test util-9.36 {TclGetIntForIndex} -body {
string index a 1.5e2
} -returnCodes error -match glob -result *
test util-9.37 {TclGetIntForIndex} -body {
string index a 0+x
} -returnCodes error -match glob -result *
test util-9.38 {TclGetIntForIndex} -body {
string index a 0+0x
} -returnCodes error -match glob -result *
test util-9.39 {TclGetIntForIndex} -body {
string index a 0+0xg
} -returnCodes error -match glob -result *
test util-9.40 {TclGetIntForIndex} -body {
string index a 0+0xg
} -returnCodes error -match glob -result *
test util-9.41 {TclGetIntForIndex} -body {
string index a 0+1.0
} -returnCodes error -match glob -result *
test util-9.42 {TclGetIntForIndex} -body {
string index a 0+1e2
} -returnCodes error -match glob -result *
test util-9.43 {TclGetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {TclGetIntForIndex} -constraints tcl -body {
string index a 0+1000000000000
} -returnCodes error -match glob -result *
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:

127
debuggers/openocd/jimtcl/tests/while.test Normal file
View File

@ -0,0 +1,127 @@
# Commands covered: while
#
# This file contains the original set of tests for Tcl's while command.
# Since the while command is now compiled, a new set of tests covering
# the new implementation is in the file "while.test". Sourcing this file
# into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: while-old.test,v 1.6 2000/04/10 17:19:06 ericm Exp $
source [file dirname [info script]]/testing.tcl
test while-old-1.1 {basic while loops} {
set count 0
while {$count < 10} {set count [expr $count+1]}
set count
} 10
test while-old-1.2 {basic while loops} {
set value xxx
while {2 > 3} {set value yyy}
set value
} xxx
test while-old-1.3 {basic while loops} {
set value 1
while {1} {
incr value;
if {$value > 5} {
break;
}
}
set value
} 6
test while-old-1.4 {basic while loops, multiline test expr} {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
}
set value
} {2}
test while-old-1.5 {basic while loops, test expr in quotes} {
set value 1
while "0 < 3" {set value 2; break}
set value
} {2}
test while-old-2.1 {continue in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
if {$index == 2} {set index [expr $index+1]; continue}
set result [concat $result [lindex $list $index]]
set index [expr $index+1]
}
set result
} {1 2 4 5}
test while-old-3.1 {break in while loop} {
set list {1 2 3 4 5}
set index 0
set result {}
while {$index < 5} {
if {$index == 3} break
set result [concat $result [lindex $list $index]]
set index [expr $index+1]
}
set result
} {1 2 3}
test while-old-4.1 {errors in while loops} {
set err [catch {while} msg]
list $err
} {1}
test while-old-4.2 {errors in while loops} {
set err [catch {while 1} msg]
list $err
} {1}
test while-old-4.3 {errors in while loops} {
set err [catch {while 1 2 3} msg]
list $err
} {1}
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err
} {1}
test while-old-4.5 {errors in while loops} {
catch {unset x}
set x 1
set err [catch {while {$x} {set x foo}} msg]
list $err
} {1}
test while-old-4.6 {errors in while loops} {
set err [catch {while {1} {error "loop aborted"}} msg]
list $err $msg
} {1 {loop aborted}}
test while-old-5.1 {while return result} {
while {0} {set a 400}
} {}
test while-old-5.2 {while return result} {
set x 1
while {$x} {set x 0}
} {}
# cleanup
testreport