Tcl Source Code

README -- Tcl test suite design document.

Contents:
---------

    1. Introduction
    2. Running tests
    3. Adding tests
    4. Incompatibilities with prior Tcl versions

1. Introduction:
----------------

This directory contains a set of validation tests for the Tcl commands
and C Library procedures for Tcl.  Each of the files whose name ends
in ".test" is intended to fully exercise the functions in the C source
file that corresponds to the file prefix.  The C functions and/or Tcl
commands tested by a given file are listed in the first line of the
file.

2. Running tests:
-----------------

We recommend that you use the "test" target of Tcl's Makefile to run
the test suite.  From the directory in which you build Tcl, simply
type "make test".  This will create a special executable named
tcltest in which the testing scripts will be evaluated.  To create
the tcltest executable without running the test suite, simple type
"make tcltest".

All the configuration options of the tcltest package are available
during a "make test" by defining the TESTFLAGS environment variable.
For example,if you wish to run only those tests in the file append.test,
you can type:

	make test TESTFLAGS="-file append.test"

For interactive testing, the Tcl Makefile provides the "runtest" target.
Type "make runtest" in your build directory, and the tcltest executable
will be created, if necessary, then it will run interactively.  At the
command prompt, you may type any Tcl commands.  If you type
"source ../tests/all.tcl", the test suite will run.  You may use the
tcltest::configure command to configure the test suite run as an
alternative to command line options via TESTFLAGS.  You might also
wish to use the tcltest::testConstraint command to select the constraints
that govern which tests are run.  See the documentation for the tcltest
package for details.

3. Adding tests:
----------------

Please see the tcltest man page for more information regarding how to
write and run tests.

Please note that the all.tcl file will source your new test file if
the filename matches the tests/*.test pattern (as it should).  The
names of test files that contain regression (or glass-box) tests
should correspond to the Tcl or C code file that they are testing.
For example, the test file for the C file "tclCmdAH.c" is
"cmdAH.test".  Test files that contain black-box tests may not
correspond to any Tcl or C code file so they should match the pattern
"*_bb.test". 

Be sure your new test file can be run from any working directory.

Be sure no temporary files are left behind by your test file.
Use [tcltest::makeFile], [tcltest::removeFile], and [tcltest::cleanupTests]
properly to be sure of this.

Be sure your tests can run cross-platform in both a build environment
as well as an installation environment.  If your test file contains
tests that should not be run in one or more of those cases, please use
the constraints mechanism to skip those tests.

4. Incompatibilities of package tcltest 2.1 with 
   testing machinery of very old versions of Tcl:
------------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig of the
   old machinery correspond to the [configure -verbose], 
   [configure -match], and [testConstraint] commands of tcltest 2.1,
   respectively.

2) VERBOSE values were longer numeric.  [configure -verbose] values
   are lists of keywords.

3) When you run "make test", the working dir for the test suite is now
   the one from which you called "make test", rather than the "tests"
   directory.  This change allows for both unix and windows test
   suites to be run simultaneously without interference with each
   other or with existing files.  All tests must now run independently
   of their working directory.

4) The "all" file is now called "all.tcl"

5) The "defs" and "defs.tcl" files no longer exist.

6) Instead of creating a doAllTests file in the tests directory, to
   run all nonPortable tests, just use the "-constraints nonPortable"
   command line flag.  If you are running interactively, you can run
   [tcltest::testConstraint nonPortable 1] (after loading the tcltest
   package).

7) Direct evaluation of the *.test files by the "source" command is no
   longer recommended.  Instead, "source all.tcl" and use the "-file" and
   "-notfile" options of tcltest::configure to control which *.test files
   are evaluated.

# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require Tcl 8.5
package require tcltest 2.2
namespace import tcltest::*
configure {*}$argv -testdir [file dir [info script]]
runAllTests

# Commands covered:  append lappend
#
# 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.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}
unset -nocomplain x

test append-1.1 {append command} {
    unset -nocomplain x
    list [append x 1 2 abc "long string"] $x
} {{12abclong string} {12abclong string}}
test append-1.2 {append command} {
    set x ""
    list [append x first] [append x second] [append x third] $x
} {first firstsecond firstsecondthird firstsecondthird}
test append-1.3 {append command} {
    set x "abcd"
    append x
} abcd

test append-2.1 {long appends} {
    set x ""
    for {set i 0} {$i < 1000} {set i [expr $i+1]} {
	append x "foobar "
    }
    set y "foobar"
    set y "$y $y $y $y $y $y $y $y $y $y"
    set y "$y $y $y $y $y $y $y $y $y $y"
    set y "$y $y $y $y $y $y $y $y $y $y "
    expr {$x == $y}
} 1

test append-3.1 {append errors} -returnCodes error -body {
    append
} -result {wrong # args: should be "append varName ?value ...?"}
test append-3.2 {append errors} -returnCodes error -body {
    set x ""
    append x(0) 44
} -result {can't set "x(0)": variable isn't array}
test append-3.3 {append errors} -returnCodes error -body {
    unset -nocomplain x
    append x
} -result {can't read "x": no such variable}

test append-4.1 {lappend command} {
    unset -nocomplain x
    list [lappend x 1 2 abc "long string"] $x
} {{1 2 abc {long string}} {1 2 abc {long string}}}
test append-4.2 {lappend command} {
    set x ""
    list [lappend x first] [lappend x second] [lappend x third] $x
} {first {first second} {first second third} {first second third}}
test append-4.3 {lappend command} -body {
    proc foo {} {
	global x
	set x old
	unset x
	lappend x new
    }
    foo
} -cleanup {
    rename foo {}
} -result {new}
test append-4.4 {lappend command} {
    set x {}
    lappend x \{\  abc
} {\{\  abc}
test append-4.5 {lappend command} {
    set x {}
    lappend x \{ abc
} {\{ abc}
test append-4.6 {lappend command} {
    set x {1 2 3}
    lappend x
} {1 2 3}
test append-4.7 {lappend command} {
    set x "a\{"
    lappend x abc
} "a\\\{ abc"
test append-4.8 {lappend command} {
    set x "\\\{"
    lappend x abc
} "\\{ abc"
test append-4.9 {lappend command} -returnCodes error -body {
    set x " \{"
    lappend x abc
} -result {unmatched open brace in list}
test append-4.10 {lappend command} -returnCodes error -body {
    set x "	\{"
    lappend x abc
} -result {unmatched open brace in list}
test append-4.11 {lappend command} -returnCodes error -body {
    set x "\{\{\{"
    lappend x abc
} -result {unmatched open brace in list}
test append-4.12 {lappend command} -returnCodes error -body {
    set x "x \{\{\{"
    lappend x abc
} -result {unmatched open brace in list}
test append-4.13 {lappend command} {
    set x "x\{\{\{"
    lappend x abc
} "x\\\{\\\{\\\{ abc"
test append-4.14 {lappend command} {
    set x " "
    lappend x abc
} "abc"
test append-4.15 {lappend command} {
    set x "\\ "
    lappend x abc
} "{ } abc"
test append-4.16 {lappend command} {
    set x "x "
    lappend x abc
} "x abc"
test append-4.17 {lappend command} {
    unset -nocomplain x
    lappend x
} {}
test append-4.18 {lappend command} {
    unset -nocomplain x
    lappend x {}
} {{}}
test append-4.19 {lappend command} {
    unset -nocomplain x
    lappend x(0)
} {}
test append-4.20 {lappend command} {
    unset -nocomplain x
    lappend x(0) abc
} {abc}
unset -nocomplain x
test append-4.21 {lappend command} -returnCodes error -body {
    set x \"
    lappend x
} -result {unmatched open quote in list}
test append-4.22 {lappend command} -returnCodes error -body {
    set x \"
    lappend x abc
} -result {unmatched open quote in list}

test append-5.1 {long lappends} -setup {
    unset -nocomplain x
    proc check {var size} {
	set l [llength $var]
	if {$l != $size} {
	    return "length mismatch: should have been $size, was $l"
	}
	for {set i 0} {$i < $size} {set i [expr $i+1]} {
	    set j [lindex $var $i]
	    if {$j ne "item $i"} {
		return "element $i should have been \"item $i\", was \"$j\""
	    }
	}
	return ok
    }
} -body {
    set x ""
    for {set i 0} {$i < 300} {incr i} {
	lappend x "item $i"
    }
    check $x 300
} -cleanup {
    rename check {}
} -result ok

test append-6.1 {lappend errors} -returnCodes error -body {
    lappend
} -result {wrong # args: should be "lappend varName ?value ...?"}
test append-6.2 {lappend errors} -returnCodes error -body {
    set x ""
    lappend x(0) 44
} -result {can't set "x(0)": variable isn't array}

test append-7.1 {lappend-created var and error in trace on that var} -setup {
    catch {rename foo ""}
    unset -nocomplain x
} -body {
    trace variable x w foo
    proc foo {} {global x; unset x}
    catch {lappend x 1}
    proc foo {args} {global x; unset x}
    info exists x
    set x
    lappend x 1
    list [info exists x] [catch {set x} msg] $msg
} -result {0 1 {can't read "x": no such variable}}
test append-7.2 {lappend var triggers read trace} -setup {
    unset -nocomplain myvar
    unset -nocomplain ::result
} -body {
    trace variable myvar r foo
    proc foo {args} {append ::result $args}
    lappend myvar a
    return $::result
} -result {myvar {} r}
test append-7.3 {lappend var triggers read trace, array var} -setup {
    unset -nocomplain myvar
    unset -nocomplain ::result
} -body {
    # The behavior of read triggers on lappend changed in 8.0 to not trigger
    # them, and was changed back in 8.4.
    trace variable myvar r foo
    proc foo {args} {append ::result $args}
    lappend myvar(b) a
    return $::result
} -result {myvar b r}
test append-7.4 {lappend var triggers read trace, array var exists} -setup {
    unset -nocomplain myvar
    unset -nocomplain ::result
} -body {
    set myvar(0) 1
    trace variable myvar r foo
    proc foo {args} {append ::result $args}
    lappend myvar(b) a
    return $::result
} -result {myvar b r}
test append-7.5 {append var does not trigger read trace} -setup {
    unset -nocomplain myvar
    unset -nocomplain ::result
} -body {
    trace variable myvar r foo
    proc foo {args} {append ::result $args}
    append myvar a
    info exists ::result
} -result {0}

# THERE ARE NO append-8.* TESTS

# New tests for bug 3057639 to show off the more consistent behaviour of
# lappend in both direct-eval and bytecompiled code paths (see appendComp.test
# for the compiled variants). lappend now behaves like append. 9.0/1 lappend -
# 9.2/3 append

test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} -setup {
    unset -nocomplain myvar
} -body {
    array set myvar {}
    proc nonull {var key val} {
	upvar 1 $var lvar
	if {![info exists lvar($key)]} {
	    return -code error "no such variable"
	}
    }
    trace add variable myvar read nonull
    list [catch {
	lappend myvar(key) "new value"
    } msg] $msg
} -result {0 {{new value}}}
test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup {
    unset -nocomplain ::env(__DUMMY__)
} -body {
    list [catch {
	lappend ::env(__DUMMY__) "new value"
    } msg] $msg
} -cleanup {
    unset -nocomplain ::env(__DUMMY__)
} -result {0 {{new value}}}
test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} -setup {
    unset -nocomplain myvar
} -body {
    array set myvar {}
    proc nonull {var key val} {
	upvar 1 $var lvar
	if {![info exists lvar($key)]} {
	    return -code error "no such variable"
	}
    }
    trace add variable myvar read nonull
    list [catch {
	append myvar(key) "new value"
    } msg] $msg
} -result {0 {new value}}
test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup {
    unset -nocomplain ::env(__DUMMY__)
} -body {
    list [catch {
	append ::env(__DUMMY__) "new value"
    } msg] $msg
} -cleanup {
    unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}

unset -nocomplain i x result y
catch {rename foo ""}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# Commands covered:  append lappend
#
# 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.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}
catch {unset x}

test appendComp-1.1 {append command} -setup {
    unset -nocomplain x
} -body {
    proc foo {} {append ::x 1 2 abc "long string"}
    list [foo] $x
} -result {{12abclong string} {12abclong string}}
test appendComp-1.2 {append command} {
    proc foo {} {
	set x ""
	list [append x first] [append x second] [append x third] $x
    }
    foo
} {first firstsecond firstsecondthird firstsecondthird}
test appendComp-1.3 {append command} {
    proc foo {} {
	set x "abcd"
	append x
    }
    foo
} abcd

test appendComp-2.1 {long appends} {
    proc foo {} {
	set x ""
	for {set i 0} {$i < 1000} {set i [expr $i+1]} {
	    append x "foobar "
	}
	set y "foobar"
	set y "$y $y $y $y $y $y $y $y $y $y"
	set y "$y $y $y $y $y $y $y $y $y $y"
	set y "$y $y $y $y $y $y $y $y $y $y "
	expr {$x == $y}
    }
    foo
} 1

test appendComp-3.1 {append errors} -returnCodes error -body {
    proc foo {} {append}
    foo
} -result {wrong # args: should be "append varName ?value ...?"}
test appendComp-3.2 {append errors} -returnCodes error -body {
    proc foo {} {
	set x ""
	append x(0) 44
    }
    foo
} -result {can't set "x(0)": variable isn't array}
test appendComp-3.3 {append errors} -returnCodes error -body {
    proc foo {} {
	unset -nocomplain x
	append x
    }
    foo
} -result {can't read "x": no such variable}

test appendComp-4.1 {lappend command} {
    proc foo {} {
	global x
	unset -nocomplain x
	lappend x 1 2 abc "long string"
    }
    list [foo] $x
} {{1 2 abc {long string}} {1 2 abc {long string}}}
test appendComp-4.2 {lappend command} {
    proc foo {} {
	set x ""
	list [lappend x first] [lappend x second] [lappend x third] $x
    }
    foo
} {first {first second} {first second third} {first second third}}
test appendComp-4.3 {lappend command} {
    proc foo {} {
	global x
	set x old
	unset x
	lappend x new
    }
    set result [foo]
    rename foo {}
    set result
} {new}
test appendComp-4.4 {lappend command} {
    proc foo {} {
	set x {}
	lappend x \{\  abc
    }
    foo
} {\{\  abc}
test appendComp-4.5 {lappend command} {
    proc foo {} {
	set x {}
	lappend x \{ abc
    }
    foo
} {\{ abc}
test appendComp-4.6 {lappend command} {
    proc foo {} {
	set x {1 2 3}
	lappend x
    }
    foo
} {1 2 3}
test appendComp-4.7 {lappend command} {
    proc foo {} {
	set x "a\{"
	lappend x abc
    }
    foo
} "a\\\{ abc"
test appendComp-4.8 {lappend command} {
    proc foo {} {
	set x "\\\{"
	lappend x abc
    }
    foo
} "\\{ abc"
test appendComp-4.9 {lappend command} -returnCodes error -body {
    proc foo {} {
	set x " \{"
	lappend x abc
    }
    foo
} -result {unmatched open brace in list}
test appendComp-4.10 {lappend command} -returnCodes error -body {
    proc foo {} {
	set x "	\{"
	lappend x abc
    }
    foo
} -result {unmatched open brace in list}
test appendComp-4.11 {lappend command} -returnCodes error -body {
    proc foo {} {
	set x "\{\{\{"
	lappend x abc
    }
    foo
} -result {unmatched open brace in list}
test appendComp-4.12 {lappend command} -returnCodes error -body {
    proc foo {} {
	set x "x \{\{\{"
	lappend x abc
    }
    foo
} -result {unmatched open brace in list}
test appendComp-4.13 {lappend command} {
    proc foo {} {
	set x "x\{\{\{"
	lappend x abc
    }
    foo
} "x\\\{\\\{\\\{ abc"
test appendComp-4.14 {lappend command} {
    proc foo {} {
	set x " "
	lappend x abc
    }
    foo
} "abc"
test appendComp-4.15 {lappend command} {
    proc foo {} {
	set x "\\ "
	lappend x abc
    }
    foo
} "{ } abc"
test appendComp-4.16 {lappend command} {
    proc foo {} {
	set x "x "
	lappend x abc
    }
    foo
} "x abc"
test appendComp-4.17 {lappend command} {
    proc foo {} { lappend x }
    foo
} {}
test appendComp-4.18 {lappend command} {
    proc foo {} { lappend x {} }
    foo
} {{}}
test appendComp-4.19 {lappend command} {
    proc foo {} { lappend x(0) }
    foo
} {}
test appendComp-4.20 {lappend command} {
    proc foo {} { lappend x(0) abc }
    foo
} {abc}

test appendComp-5.1 {long lappends} -setup {
    unset -nocomplain x
    proc check {var size} {
	set l [llength $var]
	if {$l != $size} {
	    return "length mismatch: should have been $size, was $l"
	}
	for {set i 0} {$i < $size} {incr i} {
	    set j [lindex $var $i]
	    if {$j ne "item $i"} {
		return "element $i should have been \"item $i\", was \"$j\""
	    }
	}
	return ok
    }
} -body {
    set x ""
    for {set i 0} {$i < 300} {set i [expr $i+1]} {
	lappend x "item $i"
    }
    check $x 300
} -cleanup {
    unset -nocomplain x
    catch {rename check ""}
} -result ok

test appendComp-6.1 {lappend errors} -returnCodes error -body {
    proc foo {} {lappend}
    foo
} -result {wrong # args: should be "lappend varName ?value ...?"}
test appendComp-6.2 {lappend errors} -returnCodes error -body {
    proc foo {} {
	set x ""
	lappend x(0) 44
    }
    foo
} -result {can't set "x(0)": variable isn't array}

test appendComp-7.1 {lappendComp-created var and error in trace on that var} -setup {
    catch {rename foo ""}
    unset -nocomplain x
} -body {
    proc bar {} {
	global x
	trace variable x w foo
	proc foo {} {global x; unset x}
	catch {lappend x 1}
	proc foo {args} {global x; unset x}
	info exists x
	set x
	lappend x 1
	list [info exists x] [catch {set x} msg] $msg
    }
    bar
} -result {0 1 {can't read "x": no such variable}}
test appendComp-7.2 {lappend var triggers read trace, index var} -setup {
    unset -nocomplain ::result
} -body {
    proc bar {} {
	trace variable myvar r foo
	proc foo {args} {append ::result $args}
	lappend myvar a
	return $::result
    }
    bar
} -result {myvar {} r} -constraints {bug-3057639}
test appendComp-7.3 {lappend var triggers read trace, stack var} -setup {
    unset -nocomplain ::result
    unset -nocomplain ::myvar
} -body {
    proc bar {} {
	trace variable ::myvar r foo
	proc foo {args} {append ::result $args}
	lappend ::myvar a
	return $::result
    }
    bar
} -result {::myvar {} r} -constraints {bug-3057639}
test appendComp-7.4 {lappend var triggers read trace, array var} -setup {
    unset -nocomplain ::result
} -body {
    # The behavior of read triggers on lappend changed in 8.0 to not trigger
    # them. Maybe not correct, but been there a while.
    proc bar {} {
	trace variable myvar r foo
	proc foo {args} {append ::result $args}
	lappend myvar(b) a
	return $::result
    }
    bar
} -result {myvar b r} -constraints {bug-3057639}
test appendComp-7.5 {lappend var triggers read trace, array var} -setup {
    unset -nocomplain ::result
} -body {
    # The behavior of read triggers on lappend changed in 8.0 to not trigger
    # them. Maybe not correct, but been there a while.
    proc bar {} {
	trace variable myvar r foo
	proc foo {args} {append ::result $args}
	lappend myvar(b) a b
	return $::result
    }
    bar
} -result {myvar b r}
test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup {
    unset -nocomplain ::result
} -body {
    proc bar {} {
	set myvar(0) 1
	trace variable myvar r foo
	proc foo {args} {append ::result $args}
	lappend myvar(b) a
	return $::result
    }
    bar
} -result {myvar b r} -constraints {bug-3057639}
test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup {
    unset -nocomplain ::myvar
    unset -nocomplain ::result
} -body {
    proc bar {} {
	trace variable ::myvar r foo
	proc foo {args} {append ::result $args}
	lappend ::myvar(b) a
	return $::result
    }
    bar
} -result {::myvar b r} -constraints {bug-3057639}
test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup {
    unset -nocomplain ::myvar
    unset -nocomplain ::result
} -body {
    proc bar {} {
	trace variable ::myvar r foo
	proc foo {args} {append ::result $args}
	lappend ::myvar(b) a b
	return $::result
    }
    bar
} -result {::myvar b r}
test appendComp-7.9 {append var does not trigger read trace} -setup {
    unset -nocomplain ::result
} -body {
    proc bar {} {
	trace variable myvar r foo
	proc foo {args} {append ::result $args}
	append myvar a
	info exists ::result
    }
    bar
} -result {0}

test appendComp-8.1 {defer error to runtime} -setup {
    interp create slave
} -body {
    slave eval {
	proc foo {} {
	    proc append args {}
	    append
	}
	foo
    }
} -cleanup {
    interp delete slave
} -result {}

# New tests for bug 3057639 to show off the more consistent behaviour of
# lappend in both direct-eval and bytecompiled code paths (see append.test for
# the direct-eval variants). lappend now behaves like append. 9.0/1 lappend -
# 9.2/3 append.

# Note also the tests above now constrained by bug-3057639, these changed
# behaviour with the triggering of read traces in bc mode gone.

# Going back to the tests below. The direct-eval tests are ok before and after
# patch (no read traces run for lappend, append). The compiled tests are
# failing for lappend (9.0/1) before the patch, showing how it invokes read
# traces in the compiled path. The append tests are good (9.2/3). After the
# patch the failues are gone.

test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} -setup {
    unset -nocomplain myvar
    array set myvar {}
} -body {
    proc nonull {var key val} {
	upvar 1 $var lvar
	if {![info exists lvar($key)]} {
	    return -code error "BOOM. no such variable"
	}
    }
    trace add variable myvar read nonull
    proc foo {} {
	lappend ::myvar(key) "new value"
    }
    list [catch { foo } msg] $msg
} -result {0 {{new value}}}
test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup {
    unset -nocomplain ::env(__DUMMY__)
} -body {
    proc foo {} {
	lappend ::env(__DUMMY__) "new value"
    }
    list [catch { foo } msg] $msg
} -cleanup {
    unset -nocomplain ::env(__DUMMY__)
} -result {0 {{new value}}}
test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} -setup {
    unset -nocomplain myvar
    array set myvar {}
} -body {
    proc nonull {var key val} {
	upvar 1 $var lvar
	if {![info exists lvar($key)]} {
	    return -code error "BOOM. no such variable"
	}
    }
    trace add variable myvar read nonull
    proc foo {} {
	append ::myvar(key) "new value"
    }
    list [catch { foo } msg] $msg
} -result {0 {new value}}
test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup {
    unset -nocomplain ::env(__DUMMY__)
} -body {
    proc foo {} {
	append ::env(__DUMMY__) "new value"
    }
    list [catch { foo } msg] $msg
} -cleanup {
    unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}

catch {unset i x result y}
catch {rename foo ""}
catch {rename bar ""}
catch {rename check ""}
catch {rename bar {}}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# 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.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}

if {[info commands ::apply] eq {}} {
    return
}

testConstraint memory [llength [info commands memory]]

# 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} {
    set lambda [list {{}} boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo
} {1 {argument with no name} {argument with no name
    (parsing lambda expression "{{}} boo")
    invoked from within
"apply $lambda"}}
test apply-2.3 {malformed lambda} {
    set lambda [list {{a b c}} boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo
} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c"
    (parsing lambda expression "{{a b c}} boo")
    invoked from within
"apply $lambda"}}
test apply-2.4 {malformed lambda} {
    set lambda [list a(1) boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo
} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element
    (parsing lambda expression "a(1) boo")
    invoked from within
"apply $lambda"}}
test apply-2.5 {malformed lambda} {
    set lambda [list a::b boo]
    list [catch {apply $lambda} msg] $msg $::errorInfo
} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name
    (parsing lambda expression "a::b boo")
    invoked from within
"apply $lambda"}}

# Tests for runtime errors in the lambda expression

test apply-3.1 {non-existing namespace} -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} -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} -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} -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-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-4.3 {error in arguments to lambda expression} -body {
    interp alias {} foo {} ::apply [list x {set x 1}]
    foo a b
} -cleanup {
    rename foo {}
} -returnCodes error -result {wrong # args: should be "foo x"}
test apply-4.4 {error in arguments to lambda expression} -body {
    interp alias {} foo {} ::apply [list x {set x 1}] a
    foo b
} -cleanup {
    rename foo {}
} -returnCodes error -result {wrong # args: should be "foo"}
test apply-4.5 {error in arguments to lambda expression} -body {
    set lambda [list x {set x 1}]
    namespace eval a {
	namespace ensemble create -command ::bar -map {id {::a::const foo}}
	proc const val { return $val }
	proc alias {object slot = command args} {
	    set map [namespace ensemble configure $object -map]
	    dict set map $slot [linsert $args 0 $command]
	    namespace ensemble configure $object -map $map
	}
	proc method {object name params body} {
	    set params [linsert $params 0 self]
	    alias $object $name = ::apply [list $params $body] $object
	}
	method ::bar boo x {return "[expr {$x*$x}] - $self"}
    }
    bar boo
} -cleanup {
    namespace delete ::a
} -returnCodes error -result {wrong # args: should be "bar boo x"}

test apply-5.1 {runtime error in lambda expression} {
    set lambda [list {} {error foo}]
    set res [catch {apply $lambda}]
    list $res $::errorInfo
} {1 {foo
    while executing
"error foo"
    (lambda term "{} {error foo}" line 1)
    invoked from within
"apply $lambda"}}

# 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} {
    set lambda [list {} {info level 0}]
    apply $lambda
} {apply {{} {info level 0}}}
test apply-6.3 {info level} {
    set lambda [list args {info level 0}]
    apply $lambda x y
} {apply {args {info level 0}} x y}

# 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

# 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 {}}}

# Tests for leaks

test apply-9.1 {leaking internal rep} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
    set lam [list {} {set a 1}]
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	::apply [lrange $lam 0 end]
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain lam end i tmp leakedBytes
} -result 0
test apply-9.2 {leaking internal rep} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	::apply [list {} {set a 1}]
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i tmp leakedBytes
} -result 0
test apply-9.3 {leaking internal rep} -setup {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex $lines 3 3
    }
} -constraints memory -body {
    set end [getbytes]
    for {set i 0} {$i < 5} {incr i} {
	set x [list {} {set a 1} ::NS::THAT::DOES::NOT::EXIST]
	catch {::apply $x}
	set x {}
	set tmp $end
	set end [getbytes]
    }
    set leakedBytes [expr {$end - $tmp}]
} -cleanup {
    rename getbytes {}
    unset -nocomplain end i x tmp leakedBytes
} -result 0

# Tests for the avoidance of recompilation

# cleanup

namespace delete testApply

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# assemble.test --
#
#	Test suite for the 'tcl::unsupported::assemble' command
#
# Copyright (c) 2010 by Ozgur Dogan Ugurlu.
# Copyright (c) 2010 by Kevin B. Kenny.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#-----------------------------------------------------------------------------

# Commands covered: assemble

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}
namespace eval tcl::unsupported {namespace export assemble}
namespace import tcl::unsupported::assemble

# Procedure to make code that fills the literal and local variable tables, to
# force instructions to spill to four bytes.

proc fillTables {} {
    set s {}
    set sep {}
    for {set i 0} {$i < 256} {incr i} {
	append s $sep [list set v$i literal$i]
	set sep \n
    }
    return $s
}

testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}

# assemble-1 - TclNRAssembleObjCmd

test assemble-1.1 {wrong # args, direct eval} {
    -body {
	eval [list assemble]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}
test assemble-1.2 {wrong # args, direct eval} {
    -body {
	eval [list assemble too many]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}
test assemble-1.3 {error reporting, direct eval} {
    -body {
	list [catch {
	    eval [list assemble {
		# bad opcode
		rubbish
	    }]
	} result] $result $errorInfo
    }
    -match glob
    -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":*
    while executing
"rubbish"
    ("assemble" body, line 3)*}}
    -cleanup {unset result}
}
test assemble-1.4 {simple direct eval} {
    -body {
	eval [list assemble {push {this is a test}}]
    }
    -result {this is a test}
}

# assemble-2 - CompileAssembleObj

test assemble-2.1 {bytecode reuse, direct eval} {
    -body {
	set x {push "this is a test"}
	list [eval [list assemble $x]] \
	    [eval [list assemble $x]]
    }
    -result {{this is a test} {this is a test}}
}
test assemble-2.2 {bytecode discard, direct eval} {
    -body {
	set x {load value}
	proc p1 {x} {
	    set value value1
	    assemble $x
	}
	proc p2 {x} {
	    set a b
	    set value value2
	    assemble $x
	}
	list [p1 $x] [p2 $x]
    }
    -result {value1 value2}
    -cleanup {
	unset x
	rename p1 {}
	rename p2 {}
    }
}
test assemble-2.3 {null script, direct eval} {
    -body {
	set x {}
	assemble $x
    }
    -result {}
    -cleanup {unset x}
}

# assemble-3 - TclCompileAssembleCmd

test assemble-3.1 {wrong # args, compiled path} {
    -body {
	proc x {} {
	    assemble
	}
	x
    }
    -returnCodes error
    -match glob
    -result {wrong # args:*}
}
test assemble-3.2 {wrong # args, compiled path} {
    -body {
	proc x {} {
	    assemble too many
	}
	x
    }
    -returnCodes error
    -match glob
    -result {wrong # args:*}
    -cleanup {
	rename x {}
    }
}

# assemble-4 - TclAssembleCode mainline

test assemble-4.1 {syntax error} {
    -body {
	proc x {} {
	    assemble {
		{}extra
	    }
	}
	list [catch x result] $result $::errorInfo
    }
    -cleanup {
	rename x {}
	unset result
    }
    -match glob
    -result {1 {extra characters after close-brace} {extra characters after close-brace
    while executing
"{}extra
	    "
    ("assemble" body, line 2)*}}
}
test assemble-4.2 {null command} {
    -body {
	proc x {} {
	    assemble {
		push hello; pop;;push goodbye
	    }
	}
	x
    }
    -result goodbye
    -cleanup {
	rename x {}
    }
}

# assemble-5 - GetNextOperand off-nominal cases

test assemble-5.1 {unsupported expansion} {
    -body {
	proc x {y} {
	    assemble {
		{*}$y
	    }
	}
	list [catch {x {push hello}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {
	rename x {}
	unset result
    }
}
test assemble-5.2 {unsupported substitution} {
    -body {
	proc x {y} {
	    assemble {
		$y
	    }
	}
	list [catch {x {nop}} result] $result $::errorCode
    }
    -cleanup {
	rename x {}
	unset result
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}
test assemble-5.3 {unsupported substitution} {
    -body {
	proc x {} {
	    assemble {
		[x]
	    }
	}
	list [catch {x} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}
test assemble-5.4 {backslash substitution} {
    -body {
	proc x {} {
	    assemble {
		p\x75sh\
		    hello\ world
	    }
	}
	x
    }
    -cleanup {
	rename x {}
    }
    -result {hello world}
}

# assemble-6 - ASSEM_PUSH

test assemble-6.1 {push, wrong # args} {
    -body {
	assemble push
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-6.2 {push, wrong # args} {
    -body {
	assemble {push too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-6.3 {push} {
    -body {
	eval [list assemble {push hello}]
    }
    -result hello
}
test assemble-6.4 {push4} {
    -body {
	proc x {} "
            [fillTables]
            assemble {push hello}
        "
	x
    }
    -cleanup {
	rename x {}
    }
    -result hello
}

# assemble-7 - ASSEM_1BYTE

test assemble-7.1 {add, wrong # args} {
    -body {
	assemble {add excess}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-7.2 {add} {
    -body { 
	assemble {
	    push 2
	    push 2
	    add
	} 
    }
    -result {4}
}
test assemble-7.3 {appendArrayStk} {
    -body {
	set a(b) {hello, }
	assemble {
	    push a
	    push b
	    push world
	    appendArrayStk
	}
	set a(b)
    }
    -result {hello, world}
    -cleanup {unset a}
}
test assemble-7.4 {appendStk} {
    -body {
	set a {hello, }
	assemble {
	    push a
	    push world
	    appendStk
	}
	set a
    }
    -result {hello, world}
    -cleanup {unset a}
}
test assemble-7.5 {bitwise ops} {
    -body {
	list \
	    [assemble {push 0b1100; push 0b1010; bitand}] \
	    [assemble {push 0b1100; bitnot}] \
	    [assemble {push 0b1100; push 0b1010; bitor}] \
	    [assemble {push 0b1100; push 0b1010; bitxor}]
    }
    -result {8 -13 14 6}
}
test assemble-7.6 {div} {
    -body {
	assemble {push 999999; push 7; div} 
    }
    -result 142857
}
test assemble-7.7 {dup} {
    -body {
	assemble {
	    push 1; dup; dup; add; dup; add; dup; add; add
	}
    }
    -result 9
}	
test assemble-7.8 {eq} {
    -body {
	list \
	    [assemble {push able; push baker; eq}] \
	    [assemble {push able; push able;  eq}]
    }
    -result {0 1}
}
test assemble-7.9 {evalStk} {
    -body {
	assemble {
	    push {concat test 7.3}
	    evalStk
	}
    }
    -result {test 7.3}
}
test assemble-7.9a {evalStk, syntax} {
    -body {
	assemble {
	    push {{}bad}
	    evalStk
	}
    }
    -returnCodes error
    -result {extra characters after close-brace}
}
test assemble-7.9b {evalStk, backtrace} {
    -body {
	proc y {z} {
	    error testing
	}
	proc x {} {
	    assemble {
		push {
		    # test error in evalStk
		    y asd
		}
		evalStk
	    }
	}
	list [catch x result] $result $errorInfo
    }
    -result {1 testing {testing
    while executing
"error testing"
    (procedure "y" line 2)
    invoked from within
"y asd"*}}
    -match glob
    -cleanup {
	rename y {}
	rename x {}
    }
}
test assemble-7.10 {existArrayStk} {
    -body {
	proc x {name key} {
	    set a(b) c
	    assemble {
		load name; load key; existArrayStk
	    }
	}
	list [x a a] [x a b] [x b a] [x b b]
    }
    -result {0 1 0 0}
    -cleanup {rename x {}}
}
test assemble-7.11 {existStk} {
    -body {
	proc x {name} {
	    set a b
	    assemble {
		load name; existStk
	    }
	}
	list [x a] [x b]
    }
    -result {1 0}
    -cleanup {rename x {}}
}
test assemble-7.12 {expon} {
    -body {
	assemble {push 3; push 4; expon}
    }
    -result 81
}
test assemble-7.13 {exprStk} {
    -body {
	assemble {
	    push {acos(-1)}
	    exprStk
	}
    }
    -result 3.141592653589793
}
test assemble-7.13a {exprStk, syntax} {
    -body {
	assemble {
	    push {2+}
	    exprStk
	}
    }
    -returnCodes error
    -result {missing operand at _@_
in expression "2+_@_"}
}
test assemble-7.13b {exprStk, backtrace} {
    -body {
	proc y {z} {
	    error testing
	}
	proc x {} {
	    assemble {
		push {[y asd]}
		exprStk
	    }
	}
	list [catch x result] $result $errorInfo
    }
    -result {1 testing {testing
    while executing
"error testing"
    (procedure "y" line 2)
    invoked from within
"y asd"*}}
    -match glob
    -cleanup {
	rename y {}
	rename x {}
    }
}
test assemble-7.14 {ge gt le lt} {
    -body {
	proc x {a b} {
	    list [assemble {load a; load b; ge}] \
		[assemble {load a; load b; gt}] \
		[assemble {load a; load b; le}] \
		[assemble {load a; load b; lt}]
	}
	list [x 0 0] [x 0 1] [x 1 0]
    }
    -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}}
    -cleanup {rename x {}}
}
test assemble-7.15 {incrArrayStk} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {
		push a; push b; push 7; incrArrayStk
	    }
	}
	x
    }
    -result 12
    -cleanup {rename x {}}
}
test assemble-7.16 {incrStk} {
    -body {
	proc x {} {
	    set a 5
	    assemble {
		push a; push 7; incrStk
	    }
	}
	x
    }
    -result 12
    -cleanup {rename x {}}
}
test assemble-7.17 {land/lor} {
    -body {
	proc x {a b} {
	    list \
		[assemble {load a; load b; land}] \
		[assemble {load a; load b; lor}]
	}
	list [x 0 0] [x 0 23] [x 35 0] [x 47 59]
    }
    -result {{0 0} {0 1} {0 1} {1 1}}
    -cleanup {rename x {}}
}
test assemble-7.18 {lappendArrayStk} {
    -body {
	proc x {} {
	    set able(baker) charlie
	    assemble {
		push able
		push baker
		push dog
		lappendArrayStk
	    }
	}
	x
    }
    -result {charlie dog}
    -cleanup {rename x {}}
}
test assemble-7.19 {lappendStk} {
    -body {
	proc x {} {
	    set able baker
	    assemble {
		push able
		push charlie
		lappendStk
	    }
	}
	x
    }
    -result {baker charlie}
    -cleanup {rename x {}}
}
test assemble-7.20 {listIndex} {
    -body {
	assemble {
	    push {a b c d}
	    push 2
	    listIndex
	}
    }
    -result c
}
test assemble-7.21 {listLength} {
    -body {
	assemble {
	    push {a b c d}
	    listLength
	}
    }
    -result 4
}
test assemble-7.22 {loadArrayStk} {
    -body {
	proc x {} {
	    set able(baker) charlie
	    assemble {
		push able
		push baker
		loadArrayStk
	    }
	}
	x
    }
    -result charlie
    -cleanup {rename x {}}
}
test assemble-7.23 {loadStk} {
    -body {
	proc x {} {
	    set able baker
	    assemble {
		push able
		loadStk
	    }
	}
	x
    }
    -result baker
    -cleanup {rename x {}}
}
test assemble-7.24 {lsetList} {
    -body {
	proc x {} {
	    set l {{a b} {c d} {e f} {g h}}
	    assemble {
		push {2 1}; push i; load l; lsetList
	    }
	}
	x
    }
    -result {{a b} {c d} {e i} {g h}}
}
test assemble-7.25 {lshift} {
    -body {
	assemble {push 16; push 4; lshift}
    } 
    -result 256
}
test assemble-7.26 {mod} {
    -body {
	assemble {push 123456; push 1000; mod}
    }
    -result 456
}
test assemble-7.27 {mult} {
    -body {
	assemble {push 12345679; push 9; mult}
    }
    -result 111111111
}
test assemble-7.28 {neq} {
    -body {
	list \
	    [assemble {push able; push baker; neq}] \
	    [assemble {push able; push able;  neq}]
    }
    -result {1 0}
}
test assemble-7.29 {not} {
    -body {
	list \
	    [assemble {push 17; not}] \
	    [assemble {push 0; not}]
    }
    -result {0 1}
}
test assemble-7.30 {pop} {
    -body {
	assemble {push this; pop; push that}
    }
    -result that
}
test assemble-7.31 {rshift} {
    -body {
	assemble {push 257; push 4; rshift}
    } 
    -result 16
}
test assemble-7.32 {storeArrayStk} {
    -body {
	proc x {} {
	    assemble {
		push able; push baker; push charlie; storeArrayStk
	    }
	    array get able
	}
	x
    }
    -result {baker charlie}
    -cleanup {rename x {}}
}
test assemble-7.33 {storeStk} {
    -body {
	proc x {} {
	    assemble {
		push able; push baker; storeStk
	    }
	    set able
	}
	x
    }
    -result {baker}
    -cleanup {rename x {}}
}
test assemble-7,34 {strcmp} {
    -body {
	proc x {a b} {
	    assemble {
		load a; load b; strcmp
	    }
	}
	list [x able baker] [x baker able] [x baker baker]
    }
    -result {-1 1 0}
    -cleanup {rename x {}}
}
test assemble-7.35 {streq/strneq} {
    -body {
	proc x {a b} {
	    list \
		[assemble {load a; load b; streq}] \
		[assemble {load a; load b; strneq}]
	}
	list [x able able] [x able baker]
    }
    -result {{1 0} {0 1}}
    -cleanup {rename x {}}
}
test assemble-7.36 {strindex} {
    -body {
	assemble {push testing; push 4; strindex}
    }
    -result i
}
test assemble-7.37 {strlen} {
    -body {
	assemble {push testing; strlen}
    }
    -result 7
}
test assemble-7.38 {sub} {
    -body {
	assemble {push 42; push 17; sub}
    }
    -result 25
}
test assemble-7.39 {tryCvtToNumeric} {
    -body {
	assemble {
	    push 42; tryCvtToNumeric
	}
    }
    -result 42
}
# assemble-7.40 absent
test assemble-7.41 {uminus} {
    -body {
	assemble {
	    push 42; uminus
	}
    }
    -result -42
}
test assemble-7.42 {uplus} {
    -body {
	assemble {
	    push 42; uplus
	}
    }
    -result 42
}
test assemble-7.43 {uplus} {
    -body {
	assemble {
	    push NaN; uplus
	}
    }
    -returnCodes error
    -result {can't use non-numeric floating-point value as operand of "+"}
}
test assemble-7.43.1 {tryCvtToNumeric} {
    -body {
	assemble {
	    push NaN; tryCvtToNumeric
	}
    }
    -returnCodes error
    -result {domain error: argument not in valid range}
}
test assemble-7.44 {listIn} {
    -body {
	assemble {
	    push b; push {a b c}; listIn
	}
    }
    -result 1
}
test assemble-7.45 {listNotIn} {
    -body {
	assemble {
	    push d; push {a b c}; listNotIn
	}
    }
    -result 1
}
test assemble-7.46 {nop} {
    -body {
	assemble { push x; nop; nop; nop}
    }
    -result x
}

# assemble-8 ASSEM_LVT and FindLocalVar

test assemble-8.1 {load, wrong # args} {
    -body {
	assemble load
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-8.2 {load, wrong # args} {
    -body {
	assemble {load too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-8.3 {nonlocal var} {
    -body {
	list [catch {assemble {load ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}
test assemble-8.4 {bad context} {
    -body {
	set x 1
	list [catch {assemble {load x}} result] $result $errorCode
    }
    -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
    -cleanup {unset result}
}
test assemble-8.5 {bad context} {
    -body {
	namespace eval assem {
	    set x 1
	    list [catch {assemble {load x}} result] $result $errorCode
	}
    }
    -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}}
    -cleanup {namespace delete assem}
}
test assemble-8.6 {load1} {
    -body {
	proc x {a} {
	    assemble {
		load a
	    }
	}
	x able
    }
    -result able
    -cleanup {rename x {}}
}
test assemble-8.7 {load4} {
    -body {
	proc x {a} "
	    [fillTables]
            set b \$a
            assemble {load b}
        "
	x able
    }
    -result able
    -cleanup {rename x {}}
}
test assemble-8.8 {loadArray1} {
    -body {
	proc x {} {
	    set able(baker) charlie
	    assemble {
		push baker
		loadArray able
	    }
	}
	x
    }
    -result charlie
    -cleanup {rename x {}}
}
test assemble-8.9 {loadArray4} {
    -body "
	proc x {} {
            [fillTables]
	    set able(baker) charlie
	    assemble {
		push baker
		loadArray able
	    }
	}
	x
    "
    -result charlie
    -cleanup {rename x {}}
}
test assemble-8.10 {append1} {
    -body {
	proc x {} {
	    set y {hello, }
	    assemble {
		push world; append y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.11 {append4} {
    -body {
	proc x {} "
            [fillTables]
	    set y {hello, }
	    assemble {
		push world; append y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.12 {appendArray1} {
    -body {
	proc x {} {
	    set y(z) {hello, }
	    assemble {
		push z; push world; appendArray y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.13 {appendArray4} {
    -body {
	proc x {} "
            [fillTables]
	    set y(z) {hello, }
	    assemble {
		push z; push world; appendArray y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.14 {lappend1} {
    -body {
	proc x {} {
	    set y {hello,}
	    assemble {
		push world; lappend y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.15 {lappend4} {
    -body {
	proc x {} "
            [fillTables]
	    set y {hello,}
	    assemble {
		push world; lappend y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.16 {lappendArray1} {
    -body {
	proc x {} {
	    set y(z) {hello,}
	    assemble {
		push z; push world; lappendArray y
	    }
	}
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.17 {lappendArray4} {
    -body {
	proc x {} "
            [fillTables]
	    set y(z) {hello,}
	    assemble {
		push z; push world; lappendArray y
	    }
	"
	x
    }
    -result {hello, world}
    -cleanup {rename x {}}
}
test assemble-8.18 {store1} {
    -body {
	proc x {} {
	    assemble {
		push test; store y
	    }
	    set y
	}
	x
    }
    -result {test}
    -cleanup {rename x {}}
}
test assemble-8.19 {store4} {
    -body {
	proc x {} "
            [fillTables]
	    assemble {
		push test; store y
	    }
            set y
	"
	x
    }
    -result test
    -cleanup {rename x {}}
}
test assemble-8.20 {storeArray1} {
    -body {
	proc x {} {
	    assemble {
		push z; push test; storeArray y
	    }
	    set y(z)
	}
	x
    }
    -result test
    -cleanup {rename x {}}
}
test assemble-8.21 {storeArray4} {
    -body {
	proc x {} "
            [fillTables]
	    assemble {
		push z; push test; storeArray y
	    }
	"
	x
    }
    -result test
    -cleanup {rename x {}}
}

# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte

test assemble-9.1 {wrong # args} {
    -body {assemble concat}
    -result {wrong # args*}
    -match glob
    -returnCodes error
}
test assemble-9.2 {wrong # args} {
    -body {assemble {concat too many}}
    -result {wrong # args*}
    -match glob
    -returnCodes error
}
test assemble-9.3 {not a number} {
    -body {assemble {concat rubbish}}
    -result {expected integer but got "rubbish"}
    -returnCodes error
}
test assemble-9.4 {too small} {
    -body {assemble {concat -1}}
    -result {operand does not fit in one byte}
    -returnCodes error
}
test assemble-9.5 {too small} {
    -body {assemble {concat 256}}
    -result {operand does not fit in one byte}
    -returnCodes error
}
test assemble-9.6 {concat} {
    -body {
	assemble {push h; push e; push l; push l; push o; concat 5}
    }
    -result hello
}
test assemble-9.7 {concat} {
    -body {
	list [catch {assemble {concat 0}} result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {unset result}
}

# assemble-10 -- eval and expr

test assemble-10.1 {eval - wrong # args} {
    -body {
	assemble {eval}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-10.2 {eval - wrong # args} {
    -body {
	assemble {eval too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-10.3 {eval} {
    -body {
	proc x {} {
	    assemble {
		push 3
		store n
		pop
		eval {expr {3*$n + 1}}
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {rename x {}}
}
test assemble-10.4 {expr} {
    -body {
	proc x {} {
	    assemble {
		push 3
		store n
		pop
		expr {3*$n + 1}
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {rename x {}}
}
test assemble-10.5 {eval and expr - nonsimple} {
    -body {
	proc x {} {
	    assemble {
		eval "s\x65t n 3"
		pop
		expr "\x33*\$n + 1"
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {
	rename x {}
    }
}
test assemble-10.6 {eval - noncompilable} {
    -body {
	list [catch {assemble {eval $x}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}
test assemble-10.7 {expr - noncompilable} {
    -body {
	list [catch {assemble {expr $x}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend,
#			    nsupvar, variable, upvar)
		
test assemble-11.1 {exist - wrong # args} {
    -body {
	assemble {exist}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-11.2 {exist - wrong # args} {
    -body {
	assemble {exist too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-11.3 {nonlocal var} {
    -body {
	list [catch {assemble {exist ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}
test assemble-11.4 {exist} {
    -body {
	proc x {} {
	    set y z
	    list [assemble {exist y}] \
		[assemble {exist z}]
	}
	x
    }
    -result {1 0}
    -cleanup {rename x {}}
}
test assemble-11.5 {existArray} {
    -body {
	proc x {} {
	    set a(b) c
	    list [assemble {push b; existArray a}] \
		[assemble {push c; existArray a}] \
		[assemble {push a; existArray b}]
	}
	x
    }
    -result {1 0 0}
    -cleanup {rename x {}}
}
test assemble-11.6 {dictAppend} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; push 22; dictAppend dict}
	}
	x
    }
    -result {a 1 b 222 c 3}
    -cleanup {rename x {}}
}
test assemble-11.7 {dictLappend} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; push 2; dictLappend dict}
	}
	x
    }
    -result {a 1 b {2 2} c 3}
    -cleanup {rename x {}}
}
test assemble-11.8 {upvar} {
    -body {
	proc x {v} {
	    assemble {push 1; load v; upvar w; pop; load w}
	}
	proc y {} {
	    set z 123
	    x z
	}
	y
    }
    -result 123
    -cleanup {rename x {}; rename y {}}
}
test assemble-11.9 {nsupvar} {
    -body {
	namespace eval q { variable v 123 }
	proc x {} {
	    assemble {push q; push v; nsupvar y; pop; load y}
	}
	x
    }
    -result 123
    -cleanup {namespace delete q; rename x {}}
}
test assemble-11.10 {variable} {
    -body {
	namespace eval q { namespace eval r {variable v 123}}
	proc x {} {
	    assemble {push q::r::v; variable y; load y}
	}
	x
    }
    -result 123
    -cleanup {namespace delete q; rename x {}}
}

# assemble-12 - ASSEM_LVT1 (incr and incrArray)
		
test assemble-12.1 {incr - wrong # args} {
    -body {
	assemble {incr}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-12.2 {incr - wrong # args} {
    -body {
	assemble {incr too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-12.3 {incr nonlocal var} {
    -body {
	list [catch {assemble {incr ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}
test assemble-12.4 {incr} {
    -body {
	proc x {} {
	    set y 5
	    assemble {push 3; incr y}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}
test assemble-12.5 {incrArray} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push b; push 3; incrArray a}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}
test assemble-12.6 {incr, stupid stack restriction} {
    -body {
	proc x {} "
	    [fillTables]
            set y 5
            assemble {push 3; incr y}
        "
	list [catch {x} result] $result $errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {unset result; rename x {}}
}

# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm

test assemble-13.1 {incrImm - wrong # args} {
    -body {
	assemble {incrImm x}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-13.2 {incrImm - wrong # args} {
    -body {
	assemble {incrImm too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-13.3 {incrImm nonlocal var} {
    -body {
	list [catch {assemble {incrImm ::env 2}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}
test assemble-13.4 {incrImm not a number} {
    -body {
	proc x {} {
	    assemble {incrImm x rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-13.5 {incrImm too big} {
    -body {
	proc x {} {
	    assemble {incrImm x 0x80}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
test assemble-13.6 {incrImm too small} {
    -body {
	proc x {} {
	    assemble {incrImm x -0x81}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
test assemble-13.7 {incrImm} {
    -body {
	proc x {} {
	    set y 1
	    list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}]
	}
	x
    }
    -result {-127 0}
    -cleanup {rename x {}}
}
test assemble-13.8 {incrArrayImm} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push b; incrArrayImm a 3}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}
test assemble-13.9 {incrImm, stupid stack restriction} {
    -body {
	proc x {} "
	    [fillTables]
            set y 5
            assemble {incrImm y 3}
        "
	list [catch {x} result] $result $errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {unset result; rename x {}}
}

# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm)

test assemble-14.1 {incrStkImm - wrong # args} {
    -body {
	assemble {incrStkImm}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-14.2 {incrStkImm - wrong # args} {
    -body {
	assemble {incrStkImm too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-14.3 {incrStkImm not a number} {
    -body {
	proc x {} {
	    assemble {incrStkImm rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-14.4 {incrStkImm too big} {
    -body {
	proc x {} {
	    assemble {incrStkImm 0x80}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
test assemble-14.5 {incrStkImm too small} {
    -body {
	proc x {} {
	    assemble {incrStkImm -0x81}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
test assemble-14.6 {incrStkImm} {
    -body {
	proc x {} {
	    set y 1
	    list [assemble {push y; incrStkImm -0x80}] \
		[assemble {push y; incrStkImm 0x7f}]
	}
	x
    }
    -result {-127 0}
    -cleanup {rename x {}}
}
test assemble-14.7 {incrArrayStkImm} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push a; push b; incrArrayStkImm 3}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

# assemble-15 - listIndexImm

test assemble-15.1 {listIndexImm - wrong # args} {
    -body {
	assemble {listIndexImm}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-15.2 {listIndexImm - wrong # args} {
    -body {
	assemble {listIndexImm too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-15.3 {listIndexImm - bad substitution} {
    -body {
	list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}
test assemble-15.4 {listIndexImm - invalid index} {
    -body {
	assemble {listIndexImm rubbish}
    }
    -returnCodes error
    -match glob
    -result {bad index "rubbish"*}
}
test assemble-15.5 {listIndexImm} {
    -body {
	assemble {push {a b c}; listIndexImm 2}
    }
    -result c
}
test assemble-15.6 {listIndexImm} {
    -body {
	assemble {push {a b c}; listIndexImm end-1}
    }
    -result b
}
test assemble-15.7 {listIndexImm} {
    -body {
	assemble {push {a b c}; listIndexImm end}
    }
    -result c
}

# assemble-16 - invokeStk

test assemble-16.1 {invokeStk - wrong # args} {
    -body {
	assemble {invokeStk}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-16.2 {invokeStk - wrong # args} {
    -body {
	assemble {invokeStk too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-16.3 {invokeStk - not a number} {
    -body {
	proc x {} {
	    assemble {invokeStk rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-16.4 {invokeStk - no operands} {
    -body {
	proc x {} {
	    assemble {invokeStk 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-16.5 {invokeStk1} {
    -body {
	tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3}
    }
    -result {1 2}
}
test assemble-16.6 {invokeStk4} {
    -body {
	proc x {n} {
	    set code {push concat}
	    set shouldbe {}
	    for {set i 1} {$i < $n} {incr i} {
		append code \n {push a} $i
		lappend shouldbe a$i
	    }
	    append code \n {invokeStk} { } $n
	    set is [assemble $code]
	    expr {$is eq $shouldbe}
	}
	list [x 254] [x 255] [x 256] [x 257]
    }
    -result {1 1 1 1}
    -cleanup {rename x {}}
}

# assemble-17 -- jumps and labels

test assemble-17.1 {label, wrong # args} {
    -body {
	assemble {label}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-17.2 {label, wrong # args} {
    -body {
	assemble {label too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-17.3 {label, bad subst} {
    -body {
	list [catch {assemble {label $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}
test assemble-17.4 {duplicate label} {
    -body {
	list [catch {assemble {label foo; label foo}} result] \
	    $result $::errorCode
    }
    -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}}
}
test assemble-17.5 {jump, wrong # args} {
    -body {
	assemble {jump}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-17.6 {jump, wrong # args} {
    -body {
	assemble {jump too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-17.7 {jump, bad subst} {
    -body {
	list [catch {assemble {jump $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}
test assemble-17.8 {jump - ahead and back} {
    -body {
	assemble {
	    jump three

	    label one
	    push a
	    jump four

	    label two
	    push b
	    jump six

	    label three
	    push c
	    jump five

	    label four
	    push d
	    jump two

	    label five
	    push e
	    jump one

	    label six
	    push f
	    concat 6
	}
    }
    -result ceadbf
}
test assemble-17.9 {jump - resolve a label multiple times} {
    -body {
	proc x {} {
	    set case 0
	    set result {}
	    assemble {
		jump common
		
		label zero
		pop		
		incrImm case 1
		pop
		push a
		append result
		pop
		jump common
		
		label one
		pop
		incrImm case 1
		pop
		push b
		append result
		pop
		jump common
		
		label common
		load case
		dup
		push 0
		eq
		jumpTrue zero
		dup
		push 1
		eq
		jumpTrue one
		dup
		push 2
		eq
		jumpTrue two
		dup
		push 3
		eq
		jumpTrue three
		
		label two
		pop
		incrImm case 1
		pop
		push c
		append result
		pop
		jump common
		
		label three
		pop
		incrImm case 1
		pop
		push d
		append result
	    }
	}
	x
    }
    -result abcd
    -cleanup {rename x {}}
}
test assemble-17.10 {jump4 needed} {
    -body {
	assemble "push x; jump one; label two; [string repeat {dup; pop;} 128]
	      jump three; label one; jump two; label three"
    }
    -result x
}
test assemble-17.11 {jumpTrue} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTrue then
		push no
		jump else
		label then
		push yes
		label else
	    }
	}
	list [x 0] [x 1]
    }
    -result {no yes}
    -cleanup {rename x {}}
}
test assemble-17.12 {jumpFalse} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpFalse then
		push no
		jump else
		label then
		push yes
		label else
	    }
	}
	list [x 0] [x 1]
    }
    -result {yes no}
    -cleanup {rename x {}}
}
test assemble-17.13 {jump to undefined label} {
    -body {
	list [catch {assemble {jump nowhere}} result] $result $::errorCode
    }
    -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}}
}
test assemble-17.14 {jump to undefined label, line number correct?} {
    -body {
	catch {assemble {#1
	    #2
	    #3
	    jump nowhere
	    #5
	    #6
	}}
	set ::errorInfo
    }
    -match glob
    -result {*"assemble" body, line 4*}
}
test assemble-17.15 {multiple passes of code resizing} {
    -setup {
	set body {
	    push -
	}
	for {set i 0} {$i < 14} {incr i} {
	    append body "label a" $i \
		"; push a; concat 2; nop; nop; jump b" \
		$i \n
	}
	append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n
	append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n
	for {set i 0} {$i < 15} {incr i} {
	    append body "label b" $i \
		"; push b; concat 2; nop; nop; jump a" \
		[expr {$i+1}] \n
	}
	append body {label c; push -; concat 2; nop; nop; nop; jump d} \n
	append body {label b15; push b; concat 2; nop; nop; jump c} \n
	append body {label d}
	proc x {} [list assemble $body]
    }	
    -body {
	x
    }
    -cleanup {
	catch {unset body}
	catch {rename x {}}
    }
    -result -abababababababababababababababab-
}

# assemble-18 - lindexMulti

test assemble-18.1 {lindexMulti - wrong # args} {
    -body {
	assemble {lindexMulti}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-18.2 {lindexMulti - wrong # args} {
    -body {
	assemble {lindexMulti too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-18.3 {lindexMulti - bad subst} {
    -body {
	assemble {lindexMulti $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-18.4 {lindexMulti - not a number} {
    -body {
	proc x {} {
	    assemble {lindexMulti rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-18.5 {lindexMulti - bad operand count} {
    -body {
	proc x {} {
	    assemble {lindexMulti 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-18.6 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1}
    }
    -result {{a b c} {d e f} {g h j}}
}
test assemble-18.7 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2}
    }
    -result {d e f}
}
test assemble-18.8 {lindexMulti} {
    -body {
	assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3}
    }
    -result h
}

# assemble-19 - list

test assemble-19.1 {list - wrong # args} {
    -body {
	assemble {list}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-19.2 {list - wrong # args} {
    -body {
	assemble {list too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-19.3 {list - bad subst} {
    -body {
	assemble {list $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-19.4 {list - not a number} {
    -body {
	proc x {} {
	    assemble {list rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-19.5 {list - negative operand count} {
    -body {
	proc x {} {
	    assemble {list -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-19.6 {list - no args} {
    -body {
	assemble {list 0}
    }
    -result {}
}
test assemble-19.7 {list - 1 arg} {
    -body {
	assemble {push hello; list 1}
    }
    -result hello
}
test assemble-19.8 {list - 2 args} {
    -body {
	assemble {push hello; push world; list 2}
    }
    -result {hello world}
}

# assemble-20 - lsetFlat

test assemble-20.1 {lsetFlat - wrong # args} {
    -body {
	assemble {lsetFlat}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-20.2 {lsetFlat - wrong # args} {
    -body {
	assemble {lsetFlat too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-20.3 {lsetFlat - bad subst} {
    -body {
	assemble {lsetFlat $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-20.4 {lsetFlat - not a number} {
    -body {
	proc x {} {
	    assemble {lsetFlat rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-20.5 {lsetFlat - negative operand count} {
    -body {
	proc x {} {
	    assemble {lsetFlat 1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}}
    -cleanup {rename x {}; unset result}
}
test assemble-20.6 {lsetFlat} {
    -body {
	assemble {push b; push a; lsetFlat 2}
    } 
    -result b
}
test assemble-20.7 {lsetFlat} {
    -body {
	assemble {push 1; push d; push {a b c}; lsetFlat 3}
    }
    -result {a d c}
}

# assemble-21 - over

test assemble-21.1 {over - wrong # args} {
    -body {
	assemble {over}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-21.2 {over - wrong # args} {
    -body {
	assemble {over too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-21.3 {over - bad subst} {
    -body {
	assemble {over $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-21.4 {over - not a number} {
    -body {
	proc x {} {
	    assemble {over rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-21.5 {over - negative operand count} {
    -body {
	proc x {} {
	    assemble {over -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-21.6 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		over 0
		store x
		pop
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 3
    -cleanup {rename x {}}
}
test assemble-21.7 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		over 2
		store x
		pop
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

# assemble-22 - reverse

test assemble-22.1 {reverse - wrong # args} {
    -body {
	assemble {reverse}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-22.2 {reverse - wrong # args} {
    -body {
	assemble {reverse too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-22.3 {reverse - bad subst} {
    -body {
	assemble {reverse $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-22.4 {reverse - not a number} {
    -body {
	proc x {} {
	    assemble {reverse rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-22.5 {reverse - negative operand count} {
    -body {
	proc x {} {
	    assemble {reverse -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-22.6 {reverse - zero operand count} {
    -body {
	proc x {} {
	    assemble {push 1; reverse 0}
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}
test assemble-22.7 {reverse} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		reverse 1
		store x
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 3
    -cleanup {rename x {}}
}
test assemble-22.8 {reverse} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		reverse 3
		store x
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk)

test assemble-23.1 {strmatch - wrong # args} {
    -body {
	assemble {strmatch}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-23.2 {strmatch - wrong # args} {
    -body {
	assemble {strmatch too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-23.3 {strmatch - bad subst} {
    -body {
	assemble {strmatch $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-23.4 {strmatch - not a boolean} {
    -body {
	proc x {} {
	    assemble {strmatch rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-23.5 {strmatch} {
    -body {
	proc x {a b} {
	    list [assemble {load a; load b; strmatch 0}] \
		[assemble {load a; load b; strmatch 1}]
	}
	list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL]
    }
    -result {{0 0} {1 1} {0 1}}
    -cleanup {rename x {}}
}
test assemble-23.6 {unsetStk} {
    -body {
	proc x {} {
	    set a {}
	    assemble {push a; unsetStk false}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-23.7 {unsetStk} {
    -body {
	proc x {} {
	    assemble {push a; unsetStk false}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-23.8 {unsetStk} {
    -body {
	proc x {} {
	    assemble {push a; unsetStk true}
	    info exists a
	}
	x
    }
    -returnCodes error
    -result {can't unset "a": no such variable}
    -cleanup {rename x {}}
}
test assemble-23.9 {unsetArrayStk} {
    -body {
	proc x {} {
	    set a(b) {}
	    assemble {push a; push b; unsetArrayStk false}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-23.10 {unsetArrayStk} {
    -body {
	proc x {} {
	    assemble {push a; push b; unsetArrayStk false}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-23.11 {unsetArrayStk} {
    -body {
	proc x {} {
	    assemble {push a; push b; unsetArrayStk true}
	    info exists a(b)
	}
	x
    }
    -returnCodes error
    -result {can't unset "a(b)": no such variable}
    -cleanup {rename x {}}
}

# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray)

test assemble-24.1 {unset - wrong # args} {
    -body {
	assemble {unset one}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-24.2 {unset - wrong # args} {
    -body {
	assemble {unset too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-24.3 {unset - bad subst -arg 1} {
    -body {
	assemble {unset $foo bar}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-24.4 {unset - not a boolean} {
    -body {
	proc x {} {
	    assemble {unset rubbish trash}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-24.5 {unset - bad subst - arg 2} {
    -body {
	assemble {unset true $bar}
    }
    -returnCodes error
    -result {assembly code may not contain substitutions}
}
test assemble-24.6 {unset - nonlocal var} {
    -body {
	assemble {unset true ::foo::bar}
    }
    -returnCodes error
    -result {variable "::foo::bar" is not local}
}
test assemble-24.7 {unset} {
    -body {
	proc x {} {
	    set a {}
	    assemble {unset false a}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-24.8 {unset} {
    -body {
	proc x {} {
	    assemble {unset false a}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-24.9 {unset} {
    -body {
	proc x {} {
	    assemble {unset true a}
	    info exists a
	}
	x
    }
    -returnCodes error
    -result {can't unset "a": no such variable}
    -cleanup {rename x {}}
}
test assemble-24.10 {unsetArray} {
    -body {
	proc x {} {
	    set a(b) {}
	    assemble {push b; unsetArray false a}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-24.11 {unsetArray} {
    -body {
	proc x {} {
	    assemble {push b; unsetArray false a}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-24.12 {unsetArray} {
    -body {
	proc x {} {
	    assemble {push b; unsetArray true a}
	    info exists a(b)
	}
	x
    }
    -returnCodes error
    -result {can't unset "a(b)": no such variable}
    -cleanup {rename x {}}
}

# assemble-25 - dict get

test assemble-25.1 {dict get - wrong # args} {
    -body {
	assemble {dictGet}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-25.2 {dict get - wrong # args} {
    -body {
	assemble {dictGet too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-25.3 {dictGet - bad subst} {
    -body {
	assemble {dictGet $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-25.4 {dict get - not a number} {
    -body {
	proc x {} {
	    assemble {dictGet rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-25.5 {dictGet - negative operand count} {
    -body {
	proc x {} {
	    assemble {dictGet 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-25.6 {dictGet - 1 index} {
    -body {
	assemble {push {a 1 b 2}; push a; dictGet 1}
    }
    -result 1
}

# assemble-26 - dict set

test assemble-26.1 {dict set - wrong # args} {
    -body {
	assemble {dictSet 1}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-26.2 {dict get - wrong # args} {
    -body {
	assemble {dictSet too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-26.3 {dictSet - bad subst} {
    -body {
	assemble {dictSet 1 $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-26.4 {dictSet - not a number} {
    -body {
	proc x {} {
	    assemble {dictSet rubbish foo}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-26.5 {dictSet - zero operand count} {
    -body {
	proc x {} {
	    assemble {dictSet 0 foo}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-26.6 {dictSet - bad local} {
    -body {
	proc x {} {
	    assemble {dictSet 1 ::foo::bar}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}}
    -cleanup {rename x {}; unset result}
}
test assemble-26.7 {dictSet} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; push 4; dictSet 1 dict}
	}
	x
    }
    -result {a 1 b 4 c 3}
    -cleanup {rename x {}}
}

# assemble-27 - dictUnset

test assemble-27.1 {dictUnset - wrong # args} {
    -body {
	assemble {dictUnset 1}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-27.2 {dictUnset - wrong # args} {
    -body {
	assemble {dictUnset too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-27.3 {dictUnset - bad subst} {
    -body {
	assemble {dictUnset 1 $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-27.4 {dictUnset - not a number} {
    -body {
	proc x {} {
	    assemble {dictUnset rubbish foo}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-27.5 {dictUnset - zero operand count} {
    -body {
	proc x {} {
	    assemble {dictUnset 0 foo}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}
test assemble-27.6 {dictUnset - bad local} {
    -body {
	proc x {} {
	    assemble {dictUnset 1 ::foo::bar}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}}
    -cleanup {rename x {}; unset result}
}
test assemble-27.7 {dictUnset} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; dictUnset 1 dict}
	}
	x
    }
    -result {a 1 c 3}
    -cleanup {rename x {}}
}

# assemble-28 - dictIncrImm

test assemble-28.1 {dictIncrImm - wrong # args} {
    -body {
	assemble {dictIncrImm 1}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-28.2 {dictIncrImm - wrong # args} {
    -body {
	assemble {dictIncrImm too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-28.3 {dictIncrImm - bad subst} {
    -body {
	assemble {dictIncrImm 1 $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-28.4 {dictIncrImm - not a number} {
    -body {
	proc x {} {
	    assemble {dictIncrImm rubbish foo}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-28.5 {dictIncrImm - bad local} {
    -body {
	proc x {} {
	    assemble {dictIncrImm 1 ::foo::bar}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}}
    -cleanup {rename x {}; unset result}
}
test assemble-28.6 {dictIncrImm} {
    -body {
	proc x {} {
	    set dict {a 1 b 2 c 3}
	    assemble {push b; dictIncrImm 42 dict}
	}
	x
    }
    -result {a 1 b 44 c 3}
    -cleanup {rename x {}}
}

# assemble-29 - ASSEM_REGEXP

test assemble-29.1 {regexp - wrong # args} {
    -body {
	assemble {regexp}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-29.2 {regexp - wrong # args} {
    -body {
	assemble {regexp too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-29.3 {regexp - bad subst} {
    -body {
	assemble {regexp $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-29.4 {regexp - not a boolean} {
    -body {
	proc x {} {
	    assemble {regexp rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}
test assemble-29.5 {regexp} {
    -body {
	assemble {push br.*br; push abracadabra; regexp false}
    }
    -result 1
}
test assemble-29.6 {regexp} {
    -body {
	assemble {push br.*br; push aBRacadabra; regexp false}
    }
    -result 0
}
test assemble-29.7 {regexp} {
    -body {
	assemble {push br.*br; push aBRacadabra; regexp true}
    }
    -result 1
}

# assemble-30 - Catches

test assemble-30.1 {simplest possible catch} {
    -body {
	proc x {} {
	    assemble {
		beginCatch @bad
		push error
		push testing
		invokeStk 2
		pop
		push 0
		jump @ok
		label @bad
		push 1; # should be pushReturnCode
		label @ok
		endCatch
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}
test assemble-30.2 {catch in external catch conntext} {
    -body {
	proc x {} {
	    list [catch {
		assemble {
		    beginCatch @bad
		    push error
		    push testing
		    invokeStk 2
		    pop
		    push 0
		    jump @ok
		    label @bad
		    pushReturnCode
		    label @ok
		    endCatch
		}
	    } result] $result
	}
	x
    }
    -result {0 1}
    -cleanup {rename x {}}
}
test assemble-30.3 {embedded catches} {
    -body {
	proc x {} {
	    list [catch {
		assemble {
		    beginCatch @bad
		    push error
		    eval { list [catch {error whatever} result] $result }
		    invokeStk 2
		    push 0
		    reverse 2
		    jump @done
		    label @bad
		    pushReturnCode
		    pushResult
		    label @done
		    endCatch
		    list 2
		}
	    } result2] $result2
	}
	x
    }
    -result {0 {1 {1 whatever}}}
    -cleanup {rename x {}}
}
test assemble-30.4 {throw in wrong context} {
    -body {
	proc x {} {
	    list [catch {
		assemble {
		    beginCatch @bad
		    push error
		    eval { list [catch {error whatever} result] $result }
		    invokeStk 2
		    push 0
		    reverse 2
		    jump @done

		    label @bad
		    load x
		    pushResult

		    label @done
		    endCatch
		    list 2
		}
	    } result] $result $::errorCode [split $::errorInfo \n]
	}
	x
    }
    -match glob
    -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {    in assembly code between lines 10 and 15}*}}
    -cleanup {rename x {}}
}
test assemble-30.5 {unclosed catch} {
    -body {
	proc x {} {
	    assemble {
		beginCatch @error
		push 0
		jump @done
		label @error
		push 1
		label @done
		push ""
		pop
	    }
	}
	list [catch {x} result] $result $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code
    ("assemble" body, line 2)*}}
    -cleanup {rename x {}}
}
test assemble-30.6 {inconsistent catch contexts} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTrue @inblock
		beginCatch @error
		label @inblock
		push 0
		jump @done
		label @error
		push 1
		label @done
	    }
	}
	list [catch {x 2} result] $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts
    ("assemble" body, line 5)*}}
    -cleanup {rename x {}}
}

# assemble-31 - Jump tables

test assemble-31.1 {jumpTable, wrong # args} {
    -body {
	assemble {jumpTable}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-31.2 {jumpTable, wrong # args} {
    -body {
	assemble {jumpTable too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}
test assemble-31.3 {jumpTable - bad subst} {
    -body {
	assemble {jumpTable $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}
test assemble-31.4 {jumptable - not a list} {
    -body {
	assemble {jumpTable \{rubbish}
    }
    -returnCodes error
    -result {unmatched open brace in list}
}
test assemble-31.5 {jumpTable, badly structured} {
    -body {
	list [catch {assemble {
	    # line 2
	    jumpTable {one two three};# line 3
	}} result] \
	    $result $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {jump table must have an even number of list elements} {TCL ASSEM BADJUMPTABLE} {jump table must have an even number of list elements*("assemble" body, line 3)*}}
}
test assemble-31.6 {jumpTable, missing symbol} {
    -body {
	list [catch {assemble {
	    # line 2
	    jumpTable {1 a};# line 3
	}} result] \
	    $result $::errorCode $::errorInfo
    }
    -match glob
    -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}}
}
test assemble-31.7 {jumptable, actual example} {
    -setup {
	proc x {} {
	    set result {}
	    for {set i 0} {$i < 5} {incr i} {
		lappend result [assemble {
		    load i
		    jumpTable {1 @one 2 @two 3 @three}
		    push {none of the above}
		    jump @done
		    label @one
		    push one
		    jump @done
		    label @two
		    push two
		    jump @done
		    label @three
		    push three
		    label @done
		}]
	    }
	    set tcl_traceCompile 2
	    set result
	}
    }
    -body x
    -result {{none of the above} one two three {none of the above}}
    -cleanup {set tcl_traceCompile 0; rename x {}}
}

test assemble-40.1 {unbalanced stack} {
    -body {
	list \
	    [catch {
		assemble {
		    push 3
		    dup 
		    mult 
		    push 4
		    dup 
		    mult 
		    pop 
		    expon
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 1 and end of assembly code*}}
    -match glob
   -returnCodes ok
}
test assemble-40.2 {unbalanced stack} {*}{
    -body {
	list \
	    [catch {
		assemble {
		    label a
		    push {}
		    label b
		    pop
		    label c
		    pop
		    label d
		    push {}
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 7 and 9*}}
    -match glob
   -returnCodes ok
}

test assemble-41.1 {Inconsistent stack usage} {*}{
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpFalse else
		push 0
		jump then
	      label else
		push 1
		push 2
	      label then
		pop
	    }
	}
	catch {x 1}
	set errorInfo
    }
    -match glob
    -result {inconsistent stack depths on two execution paths
    ("assemble" body, line 10)*}
}
test assemble-41.2 {Inconsistent stack, jumptable and default} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTable {0 else}
		push 0
	      label else
		pop
	    }
	}
	catch {x 1}
	set errorInfo
    }
    -match glob
    -result {inconsistent stack depths on two execution paths
    ("assemble" body, line 6)*}
}
test assemble-41.3 {Inconsistent stack, two legs of jumptable} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTable {0 no 1 yes}
		label no
		push 0
		label yes
		pop
	    }
	}
	catch {x 1}
	set errorInfo
    }
    -match glob
    -result {inconsistent stack depths on two execution paths
    ("assemble" body, line 7)*}
}

test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} {
    -body {
	proc ulam {n} {
	    assemble {
		load n;		# max
		dup;		# max n
		jump start;     # max n
	    
		label loop;	# max n
		over 1;         # max n max
		over 1;		# max in max n
		ge;             # man n max>=n
		jumpTrue skip;  # max n

		reverse 2;      # n max
		pop;            # n
		dup;            # n n
	    
		label skip;	# max n
		dup;            # max n n
		push 2;         # max n n 2
		mod;            # max n n%2
		jumpTrue odd;   # max n
	    
		push 2;         # max n 2
		div;            # max n/2 -> max n
		jump start;     # max n
	     
		label odd;	# max n
		push 3;         # max n 3
		mult;           # max 3*n
		push 1;         # max 3*n 1
		add;            # max 3*n+1
	    
		label start;	# max n
		dup;		# max n n
		push 1;		# max n n 1
		neq;		# max n n>1
		jumpTrue loop;	# max n
	    
		pop;		# max
	    }
	}
	set result {}
	for {set i 1} {$i < 30} {incr i} {
	    lappend result [ulam $i]
	}
	set result
    }
    -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88}
}

test assemble-51.1 {memory leak testing} memory {
    leaktest {
	apply {{} {assemble {push hello}}}
    }
} 0
test assemble-51.2 {memory leak testing} memory {
    leaktest {
	apply {{{x 0}} {assemble {incrImm x 1}}}
    }
} 0
test assemble-51.3 {memory leak testing} memory {
    leaktest {
	apply {{n} {
	    assemble {
		load n;		# max
		dup;		# max n
		jump start;     # max n
	    
		label loop;	# max n
		over 1;         # max n max
		over 1;		# max in max n
		ge;             # man n max>=n
		jumpTrue skip;  # max n

		reverse 2;      # n max
		pop;            # n
		dup;            # n n
	    
		label skip;	# max n
		dup;            # max n n
		push 2;         # max n n 2
		mod;            # max n n%2
		jumpTrue odd;   # max n
	    
		push 2;         # max n 2
		div;            # max n/2 -> max n
		jump start;     # max n
	     
		label odd;	# max n
		push 3;         # max n 3
		mult;           # max 3*n
		push 1;         # max 3*n 1
		add;            # max 3*n+1
	    
		label start;	# max n
		dup;		# max n n
		push 1;		# max n n 1
		neq;		# max n n>1
		jumpTrue loop;	# max n
	    
		pop;		# max
	    }
	}} 1
    }
} 0
test assemble-51.4 {memory leak testing} memory {
    leaktest {
	catch {
	    apply {{} {
		assemble {reverse polish notation}
	    }}
	}
    }
} 0

rename fillTables {}
rename assemble {}

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

proc ulam1 {n} {
    set max $n
    while {$n != 1} {
	if {$n > $max} {
	    set max $n
	}
	if {$n % 2} {
	    set n [expr {3 * $n + 1}]
	} else {
	    set n [expr {$n / 2}]
	}
    }
    return $max
}

set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0

proc ulam2 {n} {
    tcl::unsupported::assemble {
	load n;		# max
	dup;		# max n
	jump start;     # max n
	
	label loop;	# max n
	over 1;         # max n max
	over 1;		# max in max n
	ge;             # man n max>=n
	jumpTrue skip;  # max n

	reverse 2;      # n max
	pop;            # n
	dup;            # n n
	
	label skip;	# max n
	dup;            # max n n
	push 2;         # max n n 2
	mod;            # max n n%2
	jumpTrue odd;   # max n
	
	push 2;         # max n 2
	div;            # max n/2 -> max n
	jump start;     # max n
	
	label odd;	# max n
	push 3;         # max n 3
	mult;           # max 3*n
	push 1;         # max 3*n 1
	add;            # max 3*n+1
	
	label start;	# max n
	dup;		# max n n
	push 1;		# max n n 1
	neq;		# max n n>1
	jumpTrue loop;	# max n
	
	pop;		# max
    }
}
set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0

proc test1 {n} {
    for {set i 1} {$i <= $n} {incr i} {
	ulam1 $i  
    }
}
proc test2 {n} {
    for {set i 1} {$i <= $n} {incr i} {
	ulam2 $i  
    }
}

for {set j 0} {$j < 10} {incr j} {
    test1 1
    set before [clock microseconds]
    test1 30000
    set after [clock microseconds]
    puts "compiled: [expr {1e-6 * ($after - $before)}]"
    
    test2 1
    set before [clock microseconds]
    test2 30000
    set after [clock microseconds]
    puts "assembled: [expr {1e-6 * ($after - $before)}]"
}
    

# This file tests the AssocData facility of Tcl
#
# 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 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.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
testConstraint testdelassocdata [llength [info commands testdelassocdata]]

test assocd-1.1 {testing setting assoc data} testsetassocdata {
   testsetassocdata a 1
} ""
test assocd-1.2 {testing setting assoc data} testsetassocdata {
   testsetassocdata a 2
} ""
test assocd-1.3 {testing setting assoc data} testsetassocdata {
   testsetassocdata 123 456
} ""
test assocd-1.4 {testing setting assoc data} testsetassocdata {
   testsetassocdata abc "abc d e f"
} ""

test assocd-2.1 {testing getting assoc data} testgetassocdata {
   testgetassocdata a
} 2
test assocd-2.2 {testing getting assoc data} testgetassocdata {
   testgetassocdata 123
} 456
test assocd-2.3 {testing getting assoc data} testgetassocdata {
   testgetassocdata abc
} {abc d e f}
test assocd-2.4 {testing getting assoc data} testgetassocdata {
   testgetassocdata xxx
} ""

test assocd-3.1 {testing deleting assoc data} testdelassocdata {
   testdelassocdata a
} ""
test assocd-3.2 {testing deleting assoc data} testdelassocdata {
   testdelassocdata 123
} ""
test assocd-3.3 {testing deleting assoc data} testdelassocdata {
   list [catch {testdelassocdata nonexistent} msg] $msg
} {0 {}}

# cleanup
::tcltest::cleanupTests
return

# Commands covered:  none
#
# This file contains a collection of tests for Tcl_AsyncCreate and related
# library procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 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.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testasync [llength [info commands testasync]]
testConstraint threaded [expr {
    [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded)
}]

proc async1 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return "new result"
}
proc async2 {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return -code error "xyzzy"
}
proc async3 {result code} {
    global aresult
    set aresult "test pattern"
    return -code $code $result
}
proc \# {result code} {
    global aresult acode
    set aresult $result
    set acode $code
    return "comment quoting"
}

if {[testConstraint testasync]} {
    set handler1 [testasync create async1]
    set handler2 [testasync create async2]
    set handler3 [testasync create async3]
    set handler4 [testasync create \#]
}
test async-1.1 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler1 "original" 0} msg] $msg \
	   $acode $aresult
} {0 {new result} 0 original}
test async-1.2 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler1 "original" 1} msg] $msg \
	   $acode $aresult
} {0 {new result} 1 original}
test async-1.3 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler2 "old" 0} msg] $msg \
	   $acode $aresult
} {1 xyzzy 0 old}
test async-1.4 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler2 "old" 3} msg] $msg \
	   $acode $aresult
} {1 xyzzy 3 old}
test async-1.5 {basic async handlers} testasync {
    set aresult xxx
    list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
} {0 foobar {test pattern}}
test async-1.6 {basic async handlers} testasync {
    set aresult xxx
    list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
} {1 foobar {test pattern}}
test async-1.7 {basic async handlers} testasync {
    set aresult xxx
    set acode yyy
    list [catch {testasync mark $handler4 "original" 0} msg] $msg \
	   $acode $aresult
} {0 {comment quoting} 0 original}

proc mult1 {result code} {
    global x
    lappend x mult1
    return -code 7 mult1
}
proc mult2 {result code} {
    global x
    lappend x mult2
    return -code 9 mult2
}
proc mult3 {result code} {
    global x hm1 hm2
    lappend x [catch {testasync mark $hm2 serial2 0}]
    lappend x [catch {testasync mark $hm1 serial1 0}]
    lappend x mult3
    return -code 11 mult3
}
if {[testConstraint testasync]} {
    set hm1 [testasync create mult1]
    set hm2 [testasync create mult2]
    set hm3 [testasync create mult3]
}
test async-2.1 {multiple handlers} testasync {
    set x {}
    list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
} {9 mult2 {0 0 mult3 mult1 mult2}}

proc del1 {result code} {
    global x hm1 hm2 hm3 hm4
    lappend x [catch {testasync mark $hm3 serial2 0}]
    lappend x [catch {testasync mark $hm1 serial1 0}]
    lappend x [catch {testasync mark $hm4 serial1 0}]
    testasync delete $hm1
    testasync delete $hm2
    testasync delete $hm3
    lappend x del1
    return -code 13 del1
}
proc del2 {result code} {
    global x
    lappend x del2
    return -code 3 del2
}
if {[testConstraint testasync]} {
    testasync delete $handler1
    testasync delete $hm2
    testasync delete $hm3
    set hm2 [testasync create del1]
    set hm3 [testasync create mult2]
    set hm4 [testasync create del2]
}

test async-3.1 {deleting handlers} testasync {
    set x {}
    list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}

test async-4.1 {async interrupting bytecode sequence} -constraints {
    testasync threaded
} -setup {
    set hm [testasync create async3]
    proc nothing {} {
	# empty proc
    }
} -body {
    apply {{handle} {
	global aresult
	set aresult {Async event not delivered}
	testasync marklater $handle
	for {set i 0} {
	    $i < 2500000  &&  $aresult eq "Async event not delivered"
	} {incr i} {
	    nothing
	}
	return $aresult
    }} $hm
} -result {test pattern} -cleanup {
    testasync delete $hm
}
test async-4.2 {async interrupting straight bytecode sequence} -constraints {
    testasync threaded
} -setup {
    set hm [testasync create async3]
} -body {
    apply {{handle} {
	global aresult
	set aresult {Async event not delivered}
	testasync marklater $handle
	for {set i 0} {
	    $i < 2500000  &&  $aresult eq "Async event not delivered"
	} {incr i} {}
	return $aresult
    }} $hm
} -result {test pattern} -cleanup {
    testasync delete $hm
}
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
    testasync threaded
} -setup {
    set hm [testasync create async3]
} -body {
    apply [list {handle} [concat {
	global aresult
	set aresult {Async event not delivered}
	testasync marklater $handle
	set i 0
    } "[string repeat {;incr i;} 1500000]after 10;" {
	return $aresult
    }]] $hm
} -result {test pattern} -cleanup {
    testasync delete $hm
}

# cleanup
if {[testConstraint testasync]} {
    testasync delete
}
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# Commands covered:  auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating the
# autoloading index.
#
# Copyright (c) 1998  Lucent Technologies, 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.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

makeFile {# Test file for:
#   auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading facility.
# Things are much more complicated with namespaces and classes.  The
# "auto_mkindex" facility can no longer be built on top of a simple regular
# expression parser.  It must recognize constructs like this:
#
#   namespace eval foo {
#       proc test {x y} { ... }
#       namespace eval bar {
#           proc another {args} { ... }
#       }
#   }
#
# Note that procedures and itcl class definitions can be nested inside of
# namespaces.
#
# Copyright (c) 1993-1998  Lucent Technologies, Inc.

# This shouldn't cause any problems
namespace import -force blt::*

# Should be able to handle "proc" definitions, even if they are preceded by
# white space.

proc normal {x y} {return [expr $x+$y]}
  proc indented {x y} {return [expr $x+$y]}

#
# Should be able to handle proc declarations within namespaces, even if they
# have explicit namespace paths.
#
namespace eval buried {
    proc inside {args} {return "inside: $args"}

    namespace export pub_*
    proc pub_one {args} {return "one: $args"}
    proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}

namespace eval buried {
    namespace eval under {
        proc neath {args} {return "neath: $args"}
    }
    namespace eval ::buried {
        proc relative {args} {return "relative: $args"}
        proc ::top {args} {return "top: $args"}
        proc ::buried::explicit {args} {return "explicit: $args"}
    }
}

# With proper hooks, we should be able to support other commands that create
# procedures

proc buried::myproc {name body args} {
    ::proc $name $body $args
}
namespace eval ::buried {
    proc mycmd1 args {return "mycmd"}
    myproc mycmd2 args {return "mycmd"}
}
::buried::myproc mycmd3 args {return "another"}

proc {buried::my proc} {name body args} {
    ::proc $name $body $args
}
namespace eval ::buried {
    proc mycmd4 args {return "mycmd"}
    {my proc} mycmd5 args {return "mycmd"}
}
{::buried::my proc} mycmd6 args {return "another"}

# A correctly functioning [auto_import] won't choke when a child namespace
# [namespace import]s from its parent.
#
namespace eval ::parent::child {
    namespace import ::parent::*
}
proc ::parent::child::test {} {}
} autoMkindex.tcl

# Save initial state of auto_mkindex_parser

auto_load auto_mkindex
if {[info exists auto_mkindex_parser::initCommands]} {
    set saveCommands $auto_mkindex_parser::initCommands
}
proc AutoMkindexTestReset {} {
    global saveCommands
    if {[info exists saveCommands]} {
	set auto_mkindex_parser::initCommands $saveCommands
    } elseif {[info exists auto_mkindex_parser::initCommands]} {
	unset auto_mkindex_parser::initCommands
    }
}

set result ""

set origDir [pwd]
cd $::tcltest::temporaryDirectory

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
    auto_mkindex . autoMkindex.tcl
    file exists tclIndex
} {1}
set element "{source [file join . autoMkindex.tcl]}"
test autoMkindex-1.3 {examine tclIndex} -setup {
    file delete tclIndex
} -body {
    auto_mkindex . autoMkindex.tcl
    namespace eval tcl_autoMkindex_tmp {
        set dir "."
        variable auto_index
        source tclIndex
        set ::result ""
        foreach elem [lsort [array names auto_index]] {
            lappend ::result [list $elem $auto_index($elem)]
        }
    }
    return $result
} -cleanup {
    namespace delete tcl_autoMkindex_tmp
} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"

test autoMkindex-2.1 {commands on the autoload path can be imported} -setup {
    file delete tclIndex
    interp create slave
} -body {
    auto_mkindex . autoMkindex.tcl
    slave eval {
        namespace eval blt {}
        set auto_path [linsert $auto_path 0 .]
        set info [list [catch {namespace import buried::*} result] $result]
        foreach name [lsort [info commands pub_*]] {
            lappend info $name [namespace origin $name]
        }
        return $info
    }
} -cleanup {
    interp delete slave
} -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two"

# Test auto_mkindex hooks

# Slave hook executes interesting code in the interp used to watch code.
test autoMkindex-3.1 {slaveHook} -setup {
    file delete tclIndex
} -body {
    auto_mkindex_parser::slavehook {
	_%@namespace eval ::blt {
	    proc foo {} {}
	    _%@namespace export foo
	}
    }
    auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* }
    auto_mkindex . autoMkindex.tcl
    file exists tclIndex
} -cleanup {
    # Reset initCommands to avoid trashing other tests
    AutoMkindexTestReset
} -result 1 
# The auto_mkindex_parser::command is used to register commands that create
# new commands.
test autoMkindex-3.2 {auto_mkindex_parser::command} -setup {
    file delete tclIndex
} -body {
    auto_mkindex_parser::command buried::myproc {name args} {
	variable index
	variable scriptFile
	append index [list set auto_index([fullname $name])] \
		" \[list source \[file join \$dir [list $scriptFile]\]\]\n"
    }
    auto_mkindex . autoMkindex.tcl
    namespace eval tcl_autoMkindex_tmp {
        set dir "."
        variable auto_index
        source tclIndex
        set ::result ""
        foreach elem [lsort [array names auto_index]] {
            lappend ::result [list $elem $auto_index($elem)]
        }
	return $::result
    }
} -cleanup {
    namespace delete tcl_autoMkindex_tmp
    # Reset initCommands to avoid trashing other tests
    AutoMkindexTestReset
} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
test autoMkindex-3.3 {auto_mkindex_parser::command} -setup {
    file delete tclIndex
} -constraints {knownBug} -body {
    auto_mkindex_parser::command {buried::my proc} {name args} {
	variable index
	variable scriptFile
	puts "my proc $name"
	append index [list set auto_index([fullname $name])] \
		" \[list source \[file join \$dir [list $scriptFile]\]\]\n"
    }
    auto_mkindex . autoMkindex.tcl
    namespace eval tcl_autoMkindex_tmp {
        set dir "."
        variable auto_index
        source tclIndex
        set ::result ""
        foreach elem [lsort [array names auto_index]] {
            lappend ::result [list $elem $auto_index($elem)]
        }
    }
    list [lsearch -inline $::result *mycmd4*] \
	[lsearch -inline $::result *mycmd5*] \
	[lsearch -inline $::result *mycmd6*]
} -cleanup {
    namespace delete tcl_autoMkindex_tmp
    # Reset initCommands to avoid trashing other tests
    AutoMkindexTestReset
} -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"

test autoMkindex-4.1 {platform independent source commands} -setup {
    file delete tclIndex
    makeDirectory pkg
    makeFile {
	package provide football 1.0
	namespace eval ::pro:: {
	    #
	    # export only public functions.
	    #
	    namespace export {[a-z]*}
	}
	namespace eval ::college:: {
	    #
	    # export only public functions.
	    #
	    namespace export {[a-z]*}
	}
	proc ::pro::team {} {
	    puts "go packers!"
	    return true
	}
	proc ::college::team {} {
	    puts "go badgers!"
	    return true
	}
    } [file join pkg samename.tcl]
} -body {
    auto_mkindex . pkg/samename.tcl
    set f [open tclIndex r]
    lsort [lrange [split [string trim [read $f]] "\n"] end-1 end]
} -cleanup {
    catch {close $f}
    removeFile [file join pkg samename.tcl]
    removeDirectory pkg
} -result {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}

test autoMkindex-5.1 {escape magic tcl chars in general code} -setup {
    file delete tclIndex
    makeDirectory pkg
    makeFile {
	set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
	set dollar2 \
	    "this string contains an escaped dollar sign -> \$foo \\\$foo"
	set bracket1 "this contains an unescaped bracket [NoSuchProc]"
	set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
	set bracket3 \
	    "this contains nested unescaped brackets [[NoSuchProc]]"
	proc testProc {} {}
    } [file join pkg magicchar.tcl]
    set result {}
} -body {
    auto_mkindex . pkg/magicchar.tcl
    set f [open tclIndex r]
    lindex [split [string trim [read $f]] "\n"] end
} -cleanup {
    catch {close $f}
    removeFile [file join pkg magicchar.tcl]
    removeDirectory pkg
} -result {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup {
    file delete tclIndex
    makeDirectory pkg
    makeFile {
	proc {[magic mojo proc]} {} {}
    } [file join pkg magicchar2.tcl]
    set result {}
    interp create slave
} -body {
    auto_mkindex . pkg/magicchar2.tcl
    # Make a slave interp to test the autoloading
    slave eval {lappend auto_path [pwd]}
    slave eval {catch {{[magic mojo proc]}}}
} -cleanup {
    interp delete slave
    removeFile [file join pkg magicchar2.tcl]
    removeDirectory pkg
} -result 0

# Clean up.

unset result
AutoMkindexTestReset
if {[info exists saveCommands]} {
    unset saveCommands
}
rename AutoMkindexTestReset ""

removeFile autoMkindex.tcl
if {[file exists tclIndex]} {
    file delete -force tclIndex
}

cd $origDir

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

# This file contains tests for the tclBasic.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it currently includes only new tests for
# code changed for the addition of Tcl namespaces. Other variable-
# related tests appear in several other test files including
# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
# and trace.test.
#
# 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.

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {unset x}

test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
            proc p {} {
                return [namespace current]
            }
        }
    }
    list [interp eval test_interp {test_ns_basic::p}] \
         [interp delete test_interp]
} {::test_ns_basic {}}

test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
} {}

test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
} {}

test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
} {}

test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
} {}

test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
} {}

test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
} {}

test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
} {}

test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}

test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
            namespace export p
            proc p {} {
                return [namespace current]
            }
        }
        namespace eval test_ns_2 {
            namespace import ::test_ns_basic::p
            variable v 27
            proc q {} {
                variable v
                return "[p] $v"
            }
        }
    }
    list [interp eval test_interp {test_ns_2::q}] \
         [interp eval test_interp {namespace delete ::}] \
         [catch {interp eval test_interp {set a 123}} msg] $msg \
         [interp delete test_interp]
} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}

test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        proc p {} {
            return 27
        }
    }
    interp alias {} localP test_interp p
    list [interp eval test_interp {p}] \
         [localP] \
         [test_interp hide p] \
         [catch {localP} msg] $msg \
         [interp delete test_interp] \
         [catch {localP} msg] $msg
} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}

# NB: More tests about hide/expose are found in interp.test

test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        namespace eval test_ns_basic {
            proc p {} {
                return [namespace current]
            }
        }
    }
    list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
	 [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
         [interp delete test_interp]
} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}}

test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
    catch {namespace delete test_ns_basic}
    catch {rename cmd ""}
    proc cmd {} {   ;# note that this is global
        return [namespace current]
    }
    namespace eval test_ns_basic {
        proc hideCmd {} {
            interp hide {} cmd
        }
        proc exposeCmd {} {
            interp expose {} cmd
        }
        proc callCmd {} {
            cmd
        }
    }
    list [test_ns_basic::callCmd] \
         [test_ns_basic::hideCmd] \
         [catch {cmd} msg] $msg \
         [test_ns_basic::exposeCmd] \
         [test_ns_basic::callCmd] \
         [namespace delete test_ns_basic]
} {:: {} 1 {invalid command name "cmd"} {} :: {}}

test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and cannot go to another namespace} {
    catch {namespace delete test_ns_basic}
    catch {rename cmd ""}
    proc cmd {} {   ;# note that this is global
        return [namespace current]
    }
    namespace eval test_ns_basic {
        proc hideCmd {} {
            interp hide {} cmd
        }
        proc exposeCmdFailing {} {
            interp expose {} cmd ::test_ns_basic::newCmd
        }
        proc exposeCmdWorkAround {} {
            interp expose {} cmd;
	    rename cmd ::test_ns_basic::newCmd;
        }
        proc callCmd {} {
            cmd
        }
    }
    list [test_ns_basic::callCmd] \
         [test_ns_basic::hideCmd] \
         [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
         [test_ns_basic::exposeCmdWorkAround] \
         [test_ns_basic::newCmd] \
         [namespace delete test_ns_basic]
} {:: {} 1 {cannot expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
    catch {rename p ""}
    catch {rename cmd ""}
    proc p {} {
        cmd
    }
    proc cmd {} {
        return 42
    }
    list [p] \
         [interp hide {} cmd] \
         [proc cmd {} {return Hello}] \
         [cmd] \
         [rename cmd ""] \
         [interp expose {} cmd] \
         [p]
} {42 {} {} Hello {} {} 42}

test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    list [testcreatecommand create] \
	 [test_ns_basic::createdcommand] \
	 [testcreatecommand delete]
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {rename value:at: ""}
    list [testcreatecommand create2] \
	 [value:at:] \
	 [testcreatecommand delete2]
} {{} {CreatedCommandProc2 in ::} {}}

test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    namespace eval test_ns_basic {}
    proc test_ns_basic::cmd {} {  ;# proc requires that ns already exist
        return [namespace current]
    }
    list [test_ns_basic::cmd] \
         [namespace delete test_ns_basic]
} {::test_ns_basic {}}

test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
} {}

test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
} {}

test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {rename cmd ""}
    namespace eval test_ns_basic {
        proc p {} {
            return "p in [namespace current]"
        }
    }
    list [test_ns_basic::p] \
         [rename test_ns_basic::p test_ns_basic::q] \
         [test_ns_basic::q] 
} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
test basic-18.2 {TclRenameCommand, existing cmd must be found} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    namespace eval test_ns_basic {
        proc p {} {
            return "p in [namespace current]"
        }
    }
    list [info commands test_ns_basic::*] \
         [rename test_ns_basic::p ""] \
         [info commands test_ns_basic::*]
} {::test_ns_basic::p {} {}}
test basic-18.4 {TclRenameCommand, bad new name} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    namespace eval test_ns_basic {
        proc p {} {
            return "p in [namespace current]"
        }
    }
    rename test_ns_basic::p :::george::martha
} {}
test basic-18.5 {TclRenameCommand, new name must not already exist} {
    namespace eval test_ns_basic {
        proc q {} {
            return 42
        }
    }
    list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
} {1 {can't rename to ":::george::martha": command already exists}}
test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {rename p ""}
    catch {rename q ""}
    proc p {} {
        return "p in [namespace current]"
    }
    proc q {} {
        return "q in [namespace current]"
    }
    namespace eval test_ns_basic {
        proc callP {} {
            p
        }
    }
    list [test_ns_basic::callP] \
         [rename q test_ns_basic::p] \
         [test_ns_basic::callP]
} {{p in ::} {} {q in ::test_ns_basic}}

test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}

test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {rename p ""}
    catch {rename q ""}
    catch {unset x}
    set x [namespace eval test_ns_basic::test_ns_basic2 {
        # the following creates a cmd in the global namespace
        testcmdtoken create p
    }]
    list [testcmdtoken name $x] \
         [rename ::p q] \
         [testcmdtoken name $x]
} {{p ::p} {} {q ::q}}
test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
    catch {rename q ""}
    set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
    list [testcmdtoken name $x] \
         [rename test_ns_basic::test_ns_basic2::p q] \
         [testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
test basic-20.3 {Tcl_GetCommandInfo, #-quoting} testcmdtoken {
    catch {rename \# ""}
    set x [testcmdtoken create \#]
    testcmdtoken name $x
} {{#} ::#}

test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}

test basic-22.1 {Tcl_GetCommandFullName} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    namespace eval test_ns_basic1 {
        namespace export cmd*
        proc cmd1 {} {}
        proc cmd2 {} {}
    }
    namespace eval test_ns_basic2 {
        namespace export *
        namespace import ::test_ns_basic1::*
        proc p {} {}
    }
    namespace eval test_ns_basic3 {
        namespace import ::test_ns_basic2::*
        proc q {} {}
        list [namespace which -command foreach] \
             [namespace which -command q] \
             [namespace which -command p] \
             [namespace which -command cmd1] \
             [namespace which -command ::test_ns_basic2::cmd2]
    }
} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}

test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
} {}

test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
    catch {interp delete test_interp}
    catch {unset x}
    interp create test_interp
    interp eval test_interp {
        proc useSet {} {
            return [set a 123]
        }
    }
    set x [interp eval test_interp {useSet}]
    interp eval test_interp {
        rename set ""
        proc set {args} {
            return "set called with $args"
        }
    }
    list $x \
         [interp eval test_interp {useSet}] \
         [interp delete test_interp]
} {123 {set called with a 123} {}}
test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {rename p ""}
    proc p {} {
        return "global p"
    }
    namespace eval test_ns_basic {
        proc p {} {
            return "namespace p"
        }
        proc callP {} {
            p
        }
    }
    list [test_ns_basic::callP] \
         [rename test_ns_basic::p ""] \
         [test_ns_basic::callP]
} {{namespace p} {} {global p}}
test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {rename p ""}
    namespace eval test_ns_basic {
        namespace export p
        proc p {} {return 42}
    }
    namespace eval test_ns_basic2 {
        namespace import ::test_ns_basic::*
        proc callP {} {
            p
        }
    }
    list [test_ns_basic2::callP] \
         [info commands test_ns_basic2::*] \
         [rename test_ns_basic::p ""] \
         [catch {test_ns_basic2::callP} msg] $msg \
         [info commands test_ns_basic2::*]
} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}

test basic-25.1 {TclCleanupCommand} {emptyTest} {
} {}

test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
    proc myHandler {msg options} {
	set ::x [dict get $options -errorinfo]
    }
    set handler [interp bgerror {}]
    interp bgerror {} [namespace which myHandler]
    set fName [makeFile {} test1]
} -body {
    # If object isn't preserved, errorInfo would be set to
    # "foo\n    while executing\n\"garbage bytes\"" because the object's
    # string would have been freed, leaving garbage bytes for the error
    # message.
    set f [open $fName w]
    fileevent $f writable "fileevent $f writable {}; error foo"
    set x {}
    vwait x
    close $f
    set x
} -cleanup {
    removeFile test1
    interp bgerror {} $handler
    rename myHandler {}
} -result "foo\n    while executing\n\"error foo\""

test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
    #
    # Follow the pure-list branch in a manner that
    #   a - the pure-list internal rep is destroyed by shimmering
    #   b - the command returns an error
    # As the error code in Tcl_EvalObjv accesses the list elements, this will
    # cause a segfault if [Bug 1119369] has not been fixed. 
    # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
    #

    set SRC [list foo 1] ;# pure-list command 
    proc foo str {
	# Shimmer pure-list to cmdName, cleanup and error
	proc $::SRC {} {}; $::SRC
	error "BAD CALL"
    }
    catch {eval $SRC}
} -result 1 -cleanup {
    rename foo {}
    rename $::SRC {}
    unset ::SRC
}

test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body {
    #
    # Follow the pure-list branch in a manner that
    #   a - the pure-list internal rep is destroyed by shimmering
    #   b - the command accesses its command line
    # This will cause a segfault if [Bug 1119369] has not been fixed. 
    # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault.
    #

    set SRC [list foo 1] ;# pure-list command 
    proc foo str {
	# Shimmer pure-list to cmdName, cleanup and error
	proc $::SRC {} {}; $::SRC
	info level 0
    }
    catch {eval $SRC}
} -result 0 -cleanup {
    rename foo {}
    rename $::SRC {}
    unset ::SRC
}

test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}

test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}

test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
} {}

test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
} {}

test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
} {}

test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
} {}

test basic-36.1 {Tcl_EvalObjv, lookup of "unknown" command} {
    catch {namespace delete {*}[namespace children :: test_ns_*]}
    catch {interp delete test_interp}
    interp create test_interp
    interp eval test_interp {
        proc unknown {args} {
            return "global unknown"
        }
        namespace eval test_ns_basic {
            proc unknown {args} {
                return "namespace unknown"
            }
        }
    }
    list [interp alias test_interp newAlias test_interp doesntExist] \
         [catch {interp eval test_interp {newAlias}} msg] $msg \
         [interp delete test_interp]
} {newAlias 0 {global unknown} {}}

test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
} {}

test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}

# Tests basic-39.* and basic-40.* refactored into trace.test

test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}

test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
} {}

test basic-43.1 {Tcl_VarEval} {emptyTest} {
} {}

test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}

test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}

test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
    catch {close $f}
    set res [catch {
	set f [open |[list [interpreter]] w+]
	fconfigure $f -buffering line
	puts $f {fconfigure stdout -buffering line}
	puts $f continue
	puts $f {puts $::errorInfo}
	puts $f {puts DONE}
	set newMsg {}
	set msg {}
	while {$newMsg != "DONE"} {
	    set newMsg [gets $f]
	    append msg "${newMsg}\n"
	}
	close $f
    } error]
    list $res $msg
} {1 {invoked "continue" outside of a loop
    while executing
"continue"
DONE
}}

test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
    set fName [makeFile {
	puts hello
	break
    } BREAKtest]
} -constraints {
    exec
} -body {
    exec [interpreter] $fName
} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {hello
invoked "break" outside of a loop
    while executing
"break"
    (file "*BREAKtest" line 3)}    

test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
    set fName [makeFile {
	interp alias {} patch {} info patchlevel
	patch
	break
    } BREAKtest]
} -constraints {
    exec
} -body {
    exec [interpreter] $fName
} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
    while executing
"break"
    (file "*BREAKtest" line 4)}    

test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
    set fName [makeFile {
	foo [set a 1] [break]
    } BREAKtest]
} -constraints {
    exec
} -body {
    exec [interpreter] $fName
} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
    while executing*
"foo \[set a 1] \[break]"
    (file "*BREAKtest" line 2)}

test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
    set fName [makeFile {
	return -code return
    } BREAKtest]
} -constraints {
    exec
} -body {
    exec [interpreter] $fName
} -cleanup {
    removeFile BREAKtest
} -returnCodes error -match glob -result {command returned bad code: 2
    while executing
"return -code return"
    (file "*BREAKtest" line 2)}

test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -constraints {
    testevalex
} -body {
    testevalex {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}

# Some lists for expansion tests to work with
set l1 [list a {b b} c d]
set l2 [list e f {g g} h]
proc l3 {} {
    list i j k {l l}
}

# Do all tests once byte compiled and once with direct string evaluation
for {set noComp 0} {$noComp <= 1} {incr noComp} {

if $noComp {
    interp alias {} run {} testevalex
    set constraints testevalex
} else {
    interp alias {} run {} if 1
    set constraints {}
}

test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body {
    run {{*}\{}
} -constraints $constraints -returnCodes error -result {unmatched open brace in list}

test basic-47.3.$noComp {Tcl_EvalEx, error during substitution} -body {
    run {{*}[error foo]}
} -constraints $constraints -returnCodes error -result foo

test basic-47.4.$noComp {Tcl_EvalEx: no expansion} $constraints {
    run {list {*} {*}	{*}}
} {* * *}

test basic-47.5.$noComp {Tcl_EvalEx: expansion} $constraints {
    run {list {*}{} {*}	{*}x {*}"y z"}
} {* x y z}

test basic-47.6.$noComp {Tcl_EvalEx: expansion to zero args} $constraints {
    run {list {*}{}}
} {}

test basic-47.7.$noComp {Tcl_EvalEx: expansion to one arg} $constraints {
    run {list {*}x}
} x

test basic-47.8.$noComp {Tcl_EvalEx: expansion to many args} $constraints {
    run {list {*}"y z"}
} {y z}

test basic-47.9.$noComp {Tcl_EvalEx: expansion and subst order} $constraints {
    set x 0
    run {list [incr x] {*}[incr x] [incr x] \
		{*}[list [incr x] [incr x]] [incr x]}
} {1 2 3 4 5 6}

test basic-47.10.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}{} a b c d e f g h i j k l m n o p q r}
} {a b c d e f g h i j k l m n o p q r}

test basic-47.11.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}1 a b c d e f g h i j k l m n o p q r}
} {1 a b c d e f g h i j k l m n o p q r}

test basic-47.12.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r}
} {1 2 a b c d e f g h i j k l m n o p q r}

test basic-47.13.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q}
} {1 2 a b c d e f g h i j k l m n o p q}

test basic-47.14.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}{} a b c d e f g h i j k l m n o p q r s}
} {a b c d e f g h i j k l m n o p q r s}

test basic-47.15.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}1 a b c d e f g h i j k l m n o p q r s}
} {1 a b c d e f g h i j k l m n o p q r s}

test basic-47.16.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}{1 2} a b c d e f g h i j k l m n o p q r s}
} {1 2 a b c d e f g h i j k l m n o p q r s}

test basic-47.17.$noComp {Tcl_EvalEx: expand and memory management} $constraints {
    run {concat {*}{} {*}{1 2} a b c d e f g h i j k l m n o p q r}
} {1 2 a b c d e f g h i j k l m n o p q r}

test basic-48.1.$noComp {expansion: parsing} $constraints {
	run { # A comment

		# Another comment
		list 1  2\
			3   {*}$::l1
            
		# Comment again
	}
} {1 2 3 a {b b} c d}

test basic-48.2.$noComp {no expansion} $constraints {
        run {list $::l1 $::l2 [l3]}
} {{a {b b} c d} {e f {g g} h} {i j k {l l}}}

test basic-48.3.$noComp {expansion} $constraints {
        run {list {*}$::l1 $::l2 {*}[l3]}
} {a {b b} c d {e f {g g} h} i j k {l l}}

test basic-48.4.$noComp {expansion: really long cmd} $constraints {
        set cmd [list list]
        for {set t 0} {$t < 500} {incr t} {
            lappend cmd {{*}$::l1}
        }
        llength [run [join $cmd]]
} 2000

test basic-48.5.$noComp {expansion: error detection} -setup {
	set l "a {a b}x y"
} -constraints $constraints -body {
	run {list $::l1 {*}$l}
} -cleanup {
	unset l
} -returnCodes 1 -result {list element in braces followed by "x" instead of space}

test basic-48.6.$noComp {expansion: odd usage} $constraints {
        run {list {*}$::l1$::l2}
} {a {b b} c de f {g g} h}

test basic-48.7.$noComp {expansion: odd usage} -constraints $constraints -body {
        run {list {*}[l3]$::l1}
} -returnCodes 1 -result {list element in braces followed by "a" instead of space}

test basic-48.8.$noComp {expansion: odd usage} $constraints {
        run {list {*}hej$::l1}
} {heja {b b} c d}

test basic-48.9.$noComp {expansion: Not all {*} should trigger} $constraints {
	run {list {*}$::l1 \{*\}$::l2 "{*}$::l1" {{*} i j k}}
} {a {b b} c d {{*}e f {g g} h} {{*}a {b b} c d} {{*} i j k}}

test basic-48.10.$noComp {expansion: expansion of command word} -setup {
	set cmd [list string range jultomte]
} -constraints $constraints -body {
	run {{*}$cmd 2 6}
} -cleanup {
	unset cmd
} -result ltomt

test basic-48.11.$noComp {expansion: expansion into nothing} -setup {
        set cmd {}
        set bar {}
} -constraints $constraints -body {
        run {{*}$cmd {*}$bar}
} -cleanup {
	unset cmd bar
} -result {}

test basic-48.12.$noComp {expansion: odd usage} $constraints {
	run {list {*}$::l1 {*}"hej hopp" {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}

test basic-48.13.$noComp {expansion: odd usage} $constraints {
	run {list {*}$::l1 {*}{hej hopp} {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}

test basic-48.14.$noComp {expansion: hash command} -setup {
        catch {rename \# ""}
        set cmd "#"
    } -constraints $constraints -body { 
           run { {*}$cmd apa bepa }
    } -cleanup {
	unset cmd
} -returnCodes 1 -result {invalid command name "#"}

test basic-48.15.$noComp {expansion: complex words} -setup {
            set a(x) [list a {b c} d e]
            set b x
            set c [list {f\ g h\ i j k} x y]
            set d {0\ 1 2 3}
    } -constraints $constraints -body {
            run { lappend d {*}$a($b) {*}[lindex $c 0] }
    } -cleanup {
	unset a b c d
} -result {{0 1} 2 3 a {b c} d e {f g} {h i} j k}

testConstraint memory [llength [info commands memory]]
test basic-48.16.$noComp {expansion: testing for leaks} -setup {
        proc getbytes {} {
            set lines [split [memory info] "\n"]
            lindex [lindex $lines 3] 3
        }
        # This test is made to stress the allocation, reallocation and
        # object reference management in Tcl_EvalEx.
        proc stress {} {
            set a x
            # Create free objects that should disappear
            set l [list 1$a 2$a 3$a 4$a 5$a 6$a 7$a]
            # A short number of words and a short result (8)
            set l [run {list {*}$l $a$a}]
            # A short number of words and a longer result (27)
            set l [run {list {*}$l $a$a {*}$l $a$a {*}$l $a$a}]
            # A short number of words and a longer result, with an error
            # This is to stress the cleanup in the error case
            if {![catch {run {_moo_ {*}$l $a$a {*}$l $a$a {*}$l}}]} {
                error "An error was expected in the previous statement"
            }
            # Many words
            set l [run {list {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a {*}$l $a$a \
                                 {*}$l $a$a}]

            if {[llength $l] != 19*28} {
                error "Bad Length: [llength $l] should be [expr {19*28}]"
            }
        }
    } -constraints [linsert $constraints 0 memory] -body {
        set end [getbytes]
        for {set i 0} {$i < 5} {incr i} {
            stress
            set tmp $end
            set end [getbytes]
        }    
        set leak [expr {$end - $tmp}]
    } -cleanup {
	unset end i tmp
	rename getbytes {}
	rename stress {}
} -result 0

test basic-48.17.$noComp {expansion: object safety} -setup {
        set old_precision $::tcl_precision
        set ::tcl_precision 4
    } -constraints $constraints -body { 
            set third [expr {1.0/3.0}]
            set l [list $third $third]
            set x [run {list $third {*}$l $third}]
	    set res [list]
            foreach t $x {
                lappend res [expr {$t * 3.0}]
            }
            set res
    } -cleanup {
        set ::tcl_precision $old_precision
        unset old_precision res t l x third
} -result {1.0 1.0 1.0 1.0}

test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
        set badcmd {
            list a b
            set apa 10
        }
        set apa 0
        list [llength [run { {*}$badcmd }]] $apa
    } -cleanup {
	unset apa badcmd
} -result {5 0}

test basic-48.19.$noComp {expansion: error checking order} -body {
        set badlist "a {}x y"
        set a 0
        set b 0
        catch {run {list [incr a] {*}$badlist [incr b]}}
        list $a $b
    } -constraints $constraints -cleanup {
	unset badlist a b
} -result {1 0}

test basic-48.20.$noComp {expansion: odd case with word boundaries} $constraints {
    run {list {*}$::l1 {*}"hej hopp" {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}

test basic-48.21.$noComp {expansion: odd case with word boundaries} $constraints {
    run {list {*}$::l1 {*}{hej hopp} {*}$::l2}
} {a {b b} c d hej hopp e f {g g} h}

test basic-48.22.$noComp {expansion: odd case with word boundaries} -body {
    run {list {*}$::l1 {*}"hej hopp {*}$::l2}
} -constraints $constraints -returnCodes error -result {missing "}

test basic-48.23.$noComp {expansion: handle return codes} -constraints $constraints -body {
        set res {}
        for {set t 0} {$t < 10} {incr t} {
            run { {*}break }
        }
        lappend res $t

        for {set t 0} {$t < 10} {incr t} {
            run { {*}continue }
            set t 20
        }
        lappend res $t

        lappend res [catch { run { {*}{error Hejsan} } } err]
        lappend res $err
    } -cleanup {
	unset res t
} -result {0 10 1 Hejsan}

} ;# End of noComp loop

test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
    set ::x global
    namespace eval ns {
	variable x namespace
	testevalex {set x changed} global
	set ::result [list $::x $x]
    }
    namespace delete ns
    set ::result
} {changed namespace}
test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
    set ::x global
    namespace eval ns {
	variable x namespace
	testevalex {set ::context $x} global
    }
    namespace delete ns
    set ::context
} {global}

# Clean up after expand tests
unset noComp l1 l2 constraints
rename l3 {}
rename run {}

 #cleanup
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return

# 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.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]

# Big test for correct ordering of data in [expr]
proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact -- $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    # little endian
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 1
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    set ieeeValues(littleEndian) 0
	    return 1
	}
	default {
	    return 0
	}
    }
}

testConstraint ieeeFloatingPoint [testIEEE]

# ----------------------------------------------------------------------

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 {unknown or ambiguous subcommand "foo": *}
test binary-1.3 {Tcl_BinaryObjCmd: format error} -returnCodes error -body {
    binary f
} -result {wrong # args: should be "binary format formatString ?arg ...?"}
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
} -result {expected binary string but got "foo" instead}

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
} -result {expected binary string but got "foo" instead}

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
} -result {expected hexadecimal string but got "foo" instead}

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
} -result {expected hexadecimal string but got "foo" instead}

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
} -result {expected integer but got "blat"}
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-13.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format f
} -result {not enough arguments for all format specifiers}
test binary-13.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format f blat
} -result {expected floating-point number but got "blat"}
test binary-13.3 {Tcl_BinaryObjCmd: format} {
    binary format f0 1.6
} {}
test binary-13.4 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format f 1.6
} \x3f\xcc\xcc\xcd
test binary-13.5 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format f 1.6
} \xcd\xcc\xcc\x3f
test binary-13.6 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format f* {1.6 3.4}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-13.7 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format f* {1.6 3.4}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.8 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format f2 {1.6 3.4}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-13.9 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format f2 {1.6 3.4}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.10 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format f2 {1.6 3.4 5.6}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-13.11 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format f2 {1.6 3.4 5.6}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-13.12 {Tcl_BinaryObjCmd: float overflow} bigEndian {
    binary format f -3.402825e+38
} \xff\x7f\xff\xff
test binary-13.13 {Tcl_BinaryObjCmd: float overflow} littleEndian {
    binary format f -3.402825e+38
} \xff\xff\x7f\xff
test binary-13.14 {Tcl_BinaryObjCmd: float underflow} bigEndian {
    binary format f -3.402825e-100
} \x80\x00\x00\x00
test binary-13.15 {Tcl_BinaryObjCmd: float underflow} littleEndian {
    binary format f -3.402825e-100
} \x00\x00\x00\x80
test binary-13.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format f2 {1.6}
} -result {number of elements in list does not match count}
test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    set a {1.6 3.4}
    binary format f $a
} -result "expected floating-point number but got \"1.6 3.4\""
test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian {
    set a {1.6 3.4}
    binary format f1 $a
} \x3f\xcc\xcc\xcd
test binary-13.19 {Tcl_BinaryObjCmd: format} littleEndian {
    set a {1.6 3.4}
    binary format f1 $a
} \xcd\xcc\xcc\x3f

test binary-14.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format d
} -result {not enough arguments for all format specifiers}
test binary-14.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format d blat
} -result {expected floating-point number but got "blat"}
test binary-14.3 {Tcl_BinaryObjCmd: format} {
    binary format d0 1.6
} {}
test binary-14.4 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format d 1.6
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.5 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format d 1.6
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-14.6 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format d* {1.6 3.4}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.7 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format d* {1.6 3.4}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.8 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format d2 {1.6 3.4}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.9 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format d2 {1.6 3.4}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian {
    binary format d2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian {
    binary format d2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format d2 {1.6}
} -result {number of elements in list does not match count}
test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    set a {1.6 3.4}
    binary format d $a
} -result "expected floating-point number but got \"1.6 3.4\""
test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian {
    set a {1.6 3.4}
    binary format d1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian {
    set a {1.6 3.4}
    binary format d1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-14.18 {FormatNumber: Bug 1116542} {
    binary scan [binary format d 1.25] d w
    set w
} 1.25

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"}

test binary-19.1 {Tcl_BinaryObjCmd: errors} -returnCodes error -body {
    binary s
} -result {wrong # args: should be "binary scan value formatString ?varName ...?"}
test binary-19.2 {Tcl_BinaryObjCmd: errors} -returnCodes error -body {
    binary scan foo
} -result {wrong # args: should be "binary scan value formatString ?varName ...?"}
test binary-19.3 {Tcl_BinaryObjCmd: scan} {
    binary scan {} {}
} 0

test binary-20.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc a
} -result {not enough arguments for all format specifiers}
test binary-20.2 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan abc a arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-20.3 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    set arg1 abc
    list [binary scan abc a0 arg1] $arg1
} -result {1 {}}
test binary-20.4 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc a* arg1] $arg1
} -result {1 abc}
test binary-20.5 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc a5 arg1] [info exists arg1]
} -result {0 0}
test binary-20.6 {Tcl_BinaryObjCmd: scan} {
    set arg1 foo
    list [binary scan abc a2 arg1] $arg1
} {1 ab}
test binary-20.7 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
    unset -nocomplain arg2
} -body {
    list [binary scan abcdef a2a2 arg1 arg2] $arg1 $arg2
} -result {2 ab cd}
test binary-20.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc a2 arg1(a)] $arg1(a)
} -result {1 ab}
test binary-20.9 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc a arg1(a)] $arg1(a)
} -result {1 a}

test binary-21.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc A
} -result {not enough arguments for all format specifiers}
test binary-21.2 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan abc A arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-21.3 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    set arg1 abc
    list [binary scan abc A0 arg1] $arg1
} -result {1 {}}
test binary-21.4 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc A* arg1] $arg1
} -result {1 abc}
test binary-21.5 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc A5 arg1] [info exists arg1]
} -result {0 0}
test binary-21.6 {Tcl_BinaryObjCmd: scan} {
    set arg1 foo
    list [binary scan abc A2 arg1] $arg1
} {1 ab}
test binary-21.7 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
    unset -nocomplain arg2
} -body {
    list [binary scan abcdef A2A2 arg1 arg2] $arg1 $arg2
} -result {2 ab cd}
test binary-21.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc A2 arg1(a)] $arg1(a)
} -result {1 ab}
test binary-21.9 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc A2 arg1(a)] $arg1(a)
} -result {1 ab}
test binary-21.10 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan abc A arg1(a)] $arg1(a)
} -result {1 a}
test binary-21.11 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan "abc def \x00  " A* arg1] $arg1
} -result {1 {abc def}}
test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -body {
    list [binary scan "abc def \x00ghi  " A* arg1] $arg1
} -result [list 1 "abc def \x00ghi"]

test binary-22.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc b
} -result {not enough arguments for all format specifiers}
test binary-22.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 b* arg1] $arg1
} {1 0100101011001010}
test binary-22.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 b arg1] $arg1
} {1 0}
test binary-22.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 b1 arg1] $arg1
} {1 0}
test binary-22.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 b0 arg1] $arg1
} {1 {}}
test binary-22.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 b5 arg1] $arg1
} {1 01001}
test binary-22.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 b8 arg1] $arg1
} {1 01001010}
test binary-22.8 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 b14 arg1] $arg1
} {1 01001010110010}
test binary-22.9 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 b14 arg1] $arg1
} {0 foo}
test binary-22.10 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 b1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-22.11 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1 arg2
} -body {
    set arg1 foo
    set arg2 bar
    list [binary scan \x07\x87\x05 b5b* arg1 arg2] $arg1 $arg2
} -result {2 11100 1110000110100000}

test binary-23.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc B
} -result {not enough arguments for all format specifiers}
test binary-23.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 B* arg1] $arg1
} {1 0101001001010011}
test binary-23.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 B arg1] $arg1
} {1 1}
test binary-23.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 B1 arg1] $arg1
} {1 1}
test binary-23.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 B0 arg1] $arg1
} {1 {}}
test binary-23.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 B5 arg1] $arg1
} {1 01010}
test binary-23.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 B8 arg1] $arg1
} {1 01010010}
test binary-23.8 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 B14 arg1] $arg1
} {1 01010010010100}
test binary-23.9 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 B14 arg1] $arg1
} {0 foo}
test binary-23.10 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 B1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-23.11 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1 arg2
} -body {
    set arg1 foo
    set arg2 bar
    list [binary scan \x70\x87\x05 B5B* arg1 arg2] $arg1 $arg2
} -result {2 01110 1000011100000101}

test binary-24.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc h
} -result {not enough arguments for all format specifiers}
test binary-24.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 h* arg1] $arg1
} {1 253a}
test binary-24.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xc2\xa3 h arg1] $arg1
} {1 2}
test binary-24.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 h1 arg1] $arg1
} {1 2}
test binary-24.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 h0 arg1] $arg1
} {1 {}}
test binary-24.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xf2\x53 h2 arg1] $arg1
} {1 2f}
test binary-24.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 h3 arg1] $arg1
} {1 253}
test binary-24.8 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 h3 arg1] $arg1
} {0 foo}
test binary-24.9 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 h1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-24.10 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1 arg2
} -body {
    set arg1 foo
    set arg2 bar
    list [binary scan \x70\x87\x05 h2h* arg1 arg2] $arg1 $arg2
} -result {2 07 7850}

test binary-25.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc H
} -result {not enough arguments for all format specifiers}
test binary-25.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 H* arg1] $arg1
} {1 52a3}
test binary-25.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xc2\xa3 H arg1] $arg1
} {1 c}
test binary-25.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x82\x53 H1 arg1] $arg1
} {1 8}
test binary-25.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 H0 arg1] $arg1
} {1 {}}
test binary-25.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xf2\x53 H2 arg1] $arg1
} {1 f2}
test binary-25.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\x53 H3 arg1] $arg1
} {1 525}
test binary-25.8 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 H3 arg1] $arg1
} {0 foo}
test binary-25.9 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 H1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-25.10 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x70\x87\x05 H2H* arg1 arg2] $arg1 $arg2
} {2 70 8705}

test binary-26.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc c
} -result {not enough arguments for all format specifiers}
test binary-26.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 c* arg1] $arg1
} {1 {82 -93}}
test binary-26.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 c arg1] $arg1
} {1 82}
test binary-26.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 c1 arg1] $arg1
} {1 82}
test binary-26.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 c0 arg1] $arg1
} {1 {}}
test binary-26.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 c2 arg1] $arg1
} {1 {82 -93}}
test binary-26.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xff c arg1] $arg1
} {1 -1}
test binary-26.8 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 c3 arg1] $arg1
} {0 foo}
test binary-26.9 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 c1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-26.10 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2
} {2 {112 -121} 5}
test binary-26.11 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 cu* arg1] $arg1
} {1 {82 163}}
test binary-26.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 cu arg1] $arg1
} {1 82}
test binary-26.13 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xff cu arg1] $arg1
} {1 255}
test binary-26.14 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x80 cuc arg1 arg2] $arg1 $arg2
} {2 128 -128}
test binary-26.15 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x80 ccu arg1 arg2] $arg1 $arg2
} {2 -128 128}

test binary-27.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc s
} -result {not enough arguments for all format specifiers}
test binary-27.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1
} {1 {-23726 21587}}
test binary-27.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 s arg1] $arg1
} {1 -23726}
test binary-27.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 s1 arg1] $arg1
} {1 -23726}
test binary-27.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 s0 arg1] $arg1
} {1 {}}
test binary-27.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1
} {1 {-23726 21587}}
test binary-27.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 s1 arg1] $arg1
} {0 foo}
test binary-27.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 s1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-27.9 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}
test binary-27.10 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1
} {1 {41810 21587}}
test binary-27.11 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2
} {2 65535 -1}
test binary-27.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2
} {2 -1 65535}

test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc S
} -result {not enough arguments for all format specifiers}
test binary-28.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1
} {1 {21155 21332}}
test binary-28.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 S arg1] $arg1
} {1 21155}
test binary-28.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 S1 arg1] $arg1
} {1 21155}
test binary-28.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 S0 arg1] $arg1
} {1 {}}
test binary-28.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1
} {1 {21155 21332}}
test binary-28.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 S1 arg1] $arg1
} {0 foo}
test binary-28.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 S1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-28.9 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}
test binary-28.10 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1
} {1 {21155 21332}}
test binary-28.11 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1
} {1 {41810 21587}}

test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc i
} -result {not enough arguments for all format specifiers}
test binary-29.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1
} {1 {1414767442 67305985}}
test binary-29.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1
} {1 1414767442}
test binary-29.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1
} {1 1414767442}
test binary-29.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53 i0 arg1] $arg1
} {1 {}}
test binary-29.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1
} {1 {1414767442 67305985}}
test binary-29.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 i1 arg1] $arg1
} {0 foo}
test binary-29.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53\x53\x54 i1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-29.9 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2
} {2 {1414767442 67305985} 5}
test binary-29.10 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2
} {2 4294967295 -1}
test binary-29.11 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2
} {2 -1 4294967295}
test binary-29.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 iuiu arg1 arg2] $arg1 $arg2
} {2 128 2147483648}

test binary-30.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc I
} -result {not enough arguments for all format specifiers}
test binary-30.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1
} {1 {1386435412 16909060}}
test binary-30.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1
} {1 1386435412}
test binary-30.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1
} {1 1386435412}
test binary-30.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53 I0 arg1] $arg1
} {1 {}}
test binary-30.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1
} {1 {1386435412 16909060}}
test binary-30.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 I1 arg1] $arg1
} {0 foo}
test binary-30.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53\x53\x54 I1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-30.9 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}
test binary-30.10 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2
} {2 4294967295 -1}
test binary-30.11 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2
} {2 -1 4294967295}
test binary-30.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1 arg2
    list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 IuIu arg1 arg2] $arg1 $arg2
} {2 2147483648 128}

test binary-31.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc f
} -result {not enough arguments for all format specifiers}
test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1
} {1 1.600000023841858}
test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1
} {1 1.600000023841858}
test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1
} {1 1.600000023841858}
test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1
} {1 1.600000023841858}
test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1
} {1 {}}
test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1
} {1 {}}
test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-31.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 f1 arg1] $arg1
} {0 foo}
test binary-31.13 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x3f\xcc\xcc\xcd f1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}

test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc d
} -result {not enough arguments for all format specifiers}
test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1
} {1 1.6}
test binary-32.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1
} {1 1.6}
test binary-32.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1
} {1 1.6}
test binary-32.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1
} {1 1.6}
test binary-32.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1
} {1 {}}
test binary-32.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1
} {1 {}}
test binary-32.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-32.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 d1 arg1] $arg1
} {0 foo}
test binary-32.13 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-32.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-32.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}

test binary-33.1 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    list [binary scan abcdefg a2xa3 arg1 arg2] $arg1 $arg2
} {2 ab def}
test binary-33.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abcdefg a3x*a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-33.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abcdefg a3x20a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-33.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abc a3x20a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-33.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x1a1 arg1] $arg1
} {1 b}
test binary-33.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x5a1 arg1] $arg1
} {1 f}
test binary-33.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x0a1 arg1] $arg1
} {1 a}

test binary-34.1 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    list [binary scan abcdefg a2Xa3 arg1 arg2] $arg1 $arg2
} {2 ab bcd}
test binary-34.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abcdefg a3X*a3 arg1 arg2] $arg1 $arg2
} {2 abc abc}
test binary-34.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abcdefg a3X20a3 arg1 arg2] $arg1 $arg2
} {2 abc abc}
test binary-34.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abc X20a3 arg1] $arg1
} {1 abc}
test binary-34.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x*X1a1 arg1] $arg1
} {1 f}
test binary-34.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x*X5a1 arg1] $arg1
} {1 b}
test binary-34.7 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x3X0a1 arg1] $arg1
} {1 d}

test binary-35.1 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
    unset -nocomplain arg2
} -returnCodes error -body {
    binary scan abcdefg a2@a3 arg1 arg2
} -result {missing count for "@" field specifier}
test binary-35.2 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abcdefg a3@*a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-35.3 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    unset -nocomplain arg2
    set arg2 foo
    list [binary scan abcdefg a3@20a3 arg1 arg2] $arg1 $arg2
} {1 abc foo}
test binary-35.4 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef @2a3 arg1] $arg1
} {1 cde}
test binary-35.5 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x*@1a1 arg1] $arg1
} {1 b}
test binary-35.6 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    list [binary scan abcdef x*@0a1 arg1] $arg1
} {1 a}

test binary-36.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abcdef u0a3
} -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-37.7 {GetFormatSpec: numbers} -returnCodes error -body {
    binary scan abcdef "x-1" foo
} -result {bad field specifier "-"}
test binary-37.8 {GetFormatSpec: numbers} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan abcdef "a0x3" arg1] $arg1
} {1 {}}
test binary-37.9 {GetFormatSpec: numbers} {
    # test format of neg numbers
    # bug report/fix provided by Harald Kirsch
    set x [binary format f* {1 -1 2 -2 0}]
    binary scan $x f* bla
    set bla
} {1.0 -1.0 2.0 -2.0 0.0}

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
test binary-38.5 {FormatNumber: word alignment} bigEndian {
    set x [binary format c1d1 1 1.6]
} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-38.6 {FormatNumber: word alignment} littleEndian {
    set x [binary format c1d1 1 1.6]
} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-38.7 {FormatNumber: word alignment} bigEndian {
    set x [binary format c1f1 1 1.6]
} \x01\x3f\xcc\xcc\xcd
test binary-38.8 {FormatNumber: word alignment} littleEndian {
    set x [binary format c1f1 1 1.6]
} \x01\xcd\xcc\xcc\x3f

test binary-39.1 {ScanNumber: sign extension} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 c2 arg1] $arg1
} {1 {82 -93}}
test binary-39.2 {ScanNumber: sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1
} {1 {513 -32511 386 -32127}}
test binary-39.3 {ScanNumber: sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1
} {1 {258 385 -32255 -32382}}
test binary-39.4 {ScanNumber: sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 -2130640639}}
test binary-39.5 {ScanNumber: sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}
test binary-39.6 {ScanNumber: no sign extension} {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 cu2 arg1] $arg1
} {1 {82 163}}
test binary-39.7 {ScanNumber: no sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 su4 arg1] $arg1
} {1 {513 33025 386 33409}}
test binary-39.8 {ScanNumber: no sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 Su4 arg1] $arg1
} {1 {258 385 33281 33154}}
test binary-39.9 {ScanNumber: no sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 iu5 arg1] $arg1
} {1 {33620225 16843137 16876033 25297153 2164326657}}
test binary-39.10 {ScanNumber: no sign extension} {
    unset -nocomplain arg1
    list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 Iu5 arg1] $arg1
} {1 {16843010 2164326657 25297153 16876033 16843137}}

test binary-40.3 {ScanNumber: NaN} -body {
    unset -nocomplain arg1
    list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
} -match glob -result {1 -NaN*}
test binary-40.4 {ScanNumber: NaN} -body {
    unset -nocomplain arg1
    list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1
} -match glob -result {1 -NaN*}

test binary-41.1 {ScanNumber: word alignment} {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.2 {ScanNumber: word alignment} {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.3 {ScanNumber: word alignment} {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.4 {ScanNumber: word alignment} {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
} {2 1 1}
test binary-41.5 {ScanNumber: word alignment} bigEndian {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.600000023841858}
test binary-41.6 {ScanNumber: word alignment} littleEndian {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
} {2 1 1.600000023841858}
test binary-41.7 {ScanNumber: word alignment} bigEndian {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} littleEndian {
    unset -nocomplain arg1; unset arg2
    list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}

test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body {
    binary ?
} -returnCodes error -match glob -result {unknown or ambiguous subcommand "?": *}

# 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

test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
    binary scan HelloTcl W x
    set x
} 5216694956358656876
test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
    binary scan lcTolleH w x
    set x
} 5216694956358656876
test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
    binary scan [binary format w [expr {wide(3) << 31}]] w x
    set x
} 6442450944
test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
    binary scan [binary format W [expr {wide(3) << 31}]] W x
    set x
} 6442450944
test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} {
    unset -nocomplain arg1
    list [binary scan \x80[string repeat \x00 7] W arg1] $arg1
} {1 -9223372036854775808}
test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
    unset -nocomplain arg1
    list [binary scan \x80[string repeat \x00 7] Wu arg1] $arg1
} {1 9223372036854775808}
test binary-43.7 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
    unset -nocomplain arg1
    list [binary scan [string repeat \x00 7]\x80 wu arg1] $arg1
} {1 9223372036854775808}
test binary-43.8 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
    unset -nocomplain arg1 arg2
    list [binary scan \x80[string repeat \x00 7]\x80[string repeat \x00 7] WuW arg1 arg2] $arg1 $arg2
} {2 9223372036854775808 -9223372036854775808}
test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
    unset -nocomplain arg1 arg2
    list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2
} {2 9223372036854775808 -9223372036854775808}

test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
    binary scan [binary format sws 16450 -1 19521] c* x
    set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
    binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
    set x
} {66 64 0 0 0 0 127 -1 -1 -1 65 76}

test binary-46.1 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
    binary format a* \u20ac
} \u00ac
test binary-46.2 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
    list [binary scan [binary format a* \u20ac\u20bd] s x] $x
} {1 -16980}
test binary-46.3 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
    set x {}
    set y {}
    set z {}
    list [binary scan [binary format a* \u20ac\u20bd] aaa x y z] $x $y $z
} "2 \u00ac \u00bd {}"
test binary-46.4 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
    set x [encoding convertto iso8859-15 \u20ac]
    set y [binary format a* $x]
    list $x $y
} "\u00a4 \u00a4"
test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
    set x [binary scan \u00a4 a* y]
    list $x $y [encoding convertfrom iso8859-15 $y]
} "1 \u00a4 \u20ac"

test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} {
    # This test is only reliable when memory debugging is turned on, but
    # without even memory debugging it should still generate the expected
    # answers and might therefore still pick up memory corruption caused by
    # [Bug 851747].
    list [binary scan aba ccc x x x] $x
} {3 97}

### 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
test binary-50.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian {
    binary scan [binary format m [expr {wide(3) << 31}]] w x
    set x
} 6442450944
test binary-50.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian {
    binary scan [binary format m [expr {wide(3) << 31}]] W x
    set x
} 6442450944

# format Q/q
test binary-51.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format Q
} -result {not enough arguments for all format specifiers}
test binary-51.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format q blat
} -result {expected floating-point number but got "blat"}
test binary-51.3 {Tcl_BinaryObjCmd: format} {
    binary format q0 1.6
} {}
test binary-51.4 {Tcl_BinaryObjCmd: format} {} {
    binary format Q 1.6
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-51.5 {Tcl_BinaryObjCmd: format} {} {
    binary format q 1.6
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-51.6 {Tcl_BinaryObjCmd: format} {} {
    binary format Q* {1.6 3.4}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-51.7 {Tcl_BinaryObjCmd: format} {} {
    binary format q* {1.6 3.4}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-51.8 {Tcl_BinaryObjCmd: format} {} {
    binary format Q2 {1.6 3.4}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-51.9 {Tcl_BinaryObjCmd: format} {} {
    binary format q2 {1.6 3.4}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-51.10 {Tcl_BinaryObjCmd: format} {} {
    binary format Q2 {1.6 3.4 5.6}
} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
test binary-51.11 {Tcl_BinaryObjCmd: format} {} {
    binary format q2 {1.6 3.4 5.6}
} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format q2 {1.6}
} -result {number of elements in list does not match count}
test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    set a {1.6 3.4}
    binary format q $a
} -result "expected floating-point number but got \"1.6 3.4\""
test binary-51.16 {Tcl_BinaryObjCmd: format} {} {
    set a {1.6 3.4}
    binary format Q1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-51.17 {Tcl_BinaryObjCmd: format} {} {
    set a {1.6 3.4}
    binary format q1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f

# format R/r
test binary-53.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format r
} -result {not enough arguments for all format specifiers}
test binary-53.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format r blat
} -result {expected floating-point number but got "blat"}
test binary-53.3 {Tcl_BinaryObjCmd: format} {
    binary format f0 1.6
} {}
test binary-53.4 {Tcl_BinaryObjCmd: format} {} {
    binary format R 1.6
} \x3f\xcc\xcc\xcd
test binary-53.5 {Tcl_BinaryObjCmd: format} {} {
    binary format r 1.6
} \xcd\xcc\xcc\x3f
test binary-53.6 {Tcl_BinaryObjCmd: format} {} {
    binary format R* {1.6 3.4}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-53.7 {Tcl_BinaryObjCmd: format} {} {
    binary format r* {1.6 3.4}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-53.8 {Tcl_BinaryObjCmd: format} {} {
    binary format R2 {1.6 3.4}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-53.9 {Tcl_BinaryObjCmd: format} {} {
    binary format r2 {1.6 3.4}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-53.10 {Tcl_BinaryObjCmd: format} {} {
    binary format R2 {1.6 3.4 5.6}
} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
test binary-53.11 {Tcl_BinaryObjCmd: format} {} {
    binary format r2 {1.6 3.4 5.6}
} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
test binary-53.12 {Tcl_BinaryObjCmd: float overflow} {} {
    binary format R -3.402825e+38
} \xff\x7f\xff\xff
test binary-53.13 {Tcl_BinaryObjCmd: float overflow} {} {
    binary format r -3.402825e+38
} \xff\xff\x7f\xff
test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} {
    binary format R -3.402825e-100
} \x80\x00\x00\x00
test binary-53.15 {Tcl_BinaryObjCmd: float underflow} {} {
    binary format r -3.402825e-100
} \x00\x00\x00\x80
test binary-53.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    binary format r2 {1.6}
} -result {number of elements in list does not match count}
test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body {
    set a {1.6 3.4}
    binary format r $a
} -result "expected floating-point number but got \"1.6 3.4\""
test binary-53.18 {Tcl_BinaryObjCmd: format} {} {
    set a {1.6 3.4}
    binary format R1 $a
} \x3f\xcc\xcc\xcd
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
    set a {1.6 3.4}
    binary format r1 $a
} \xcd\xcc\xcc\x3f

# scan t (s)
test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc t
} -result {not enough arguments for all format specifiers}
test binary-54.2 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1
} {1 {-23726 21587}}
test binary-54.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 t arg1] $arg1
} {1 -23726}
test binary-54.4 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 t1 arg1] $arg1
} {1 -23726}
test binary-54.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 t0 arg1] $arg1
} {1 {}}
test binary-54.6 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1
} {1 {-23726 21587}}
test binary-54.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 t1 arg1] $arg1
} {0 foo}
test binary-54.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 t1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}
test binary-54.10 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x80\x00\x80 tut arg1 arg2] $arg1 $arg2
} {2 32768 -32768}
test binary-54.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x80\x00\x80 ttu arg1 arg2] $arg1 $arg2
} {2 -32768 32768}

# scan t (b)
test binary-55.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc t
} -result {not enough arguments for all format specifiers}
test binary-55.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1
} {1 {21155 21332}}
test binary-55.3 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 t arg1] $arg1
} {1 21155}
test binary-55.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 t1 arg1] $arg1
} {1 21155}
test binary-55.5 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3 t0 arg1] $arg1
} {1 {}}
test binary-55.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1
} {1 {21155 21332}}
test binary-55.7 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 t1 arg1] $arg1
} {0 foo}
test binary-55.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53 t1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}
test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x80\x00 tut arg1 arg2] $arg1 $arg2
} {2 32768 -32768}
test binary-55.11 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x80\x00 ttu arg1 arg2] $arg1 $arg2
} {2 -32768 32768}

# scan n (s)
test binary-56.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc n
} -result {not enough arguments for all format specifiers}
test binary-56.2 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
} {1 {1414767442 67305985}}
test binary-56.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
} {1 1414767442}
test binary-56.4 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1
} {1 1414767442}
test binary-56.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53 n0 arg1] $arg1
} {1 {}}
test binary-56.6 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
} {1 {1414767442 67305985}}
test binary-56.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 n1 arg1] $arg1
} {0 foo}
test binary-56.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53\x53\x54 n1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
} {2 {1414767442 67305985} 5}
test binary-56.10 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x00\x00\x80\x00\x00\x00 nun arg1 arg2] $arg1 $arg2
} {2 128 128}
test binary-56.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x00\x00\x80\x00\x00\x00\x80 nun arg1 arg2] $arg1 $arg2
} {2 2147483648 -2147483648}

# scan n (b)
test binary-57.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc n
} -result {not enough arguments for all format specifiers}
test binary-57.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
} {1 {1386435412 16909060}}
test binary-57.3 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
} {1 1386435412}
test binary-57.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1
} {1 1386435412}
test binary-57.5 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53 n0 arg1] $arg1
} {1 {}}
test binary-57.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
} {1 {1386435412 16909060}}
test binary-57.7 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 n1 arg1] $arg1
} {0 foo}
test binary-57.8 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x52\x53\x53\x54 n1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}
test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x00\x00\x80\x00\x00\x00 nun arg1 arg2] $arg1 $arg2
} {2 2147483648 -2147483648}
test binary-57.11 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x00\x00\x80\x00\x00\x00\x80 nun arg1 arg2] $arg1 $arg2
} {2 128 128}

# scan Q/q
test binary-58.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc q
} -result {not enough arguments for all format specifiers}
test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q* arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q arg1] $arg1
} {1 1.6}
test binary-58.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q arg1] $arg1
} {1 1.6}
test binary-58.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q1 arg1] $arg1
} {1 1.6}
test binary-58.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q1 arg1] $arg1
} {1 1.6}
test binary-58.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q0 arg1] $arg1
} {1 {}}
test binary-58.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q0 arg1] $arg1
} {1 {}}
test binary-58.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q2 arg1] $arg1
} {1 {1.6 3.4}}
test binary-58.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 q1 arg1] $arg1
} {0 foo}
test binary-58.13 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-58.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}
test binary-58.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 q2c* arg1 arg2] $arg1 $arg2
} {2 {1.6 3.4} 5}

# scan R/r
test binary-59.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body {
    binary scan abc r
} -result {not enough arguments for all format specifiers}
test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1
} {1 1.600000023841858}
test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1
} {1 1.600000023841858}
test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1
} {1 1.600000023841858}
test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1
} {1 1.600000023841858}
test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1
} {1 {}}
test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1
} {1 {}}
test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1
} {1 {1.600000023841858 3.4000000953674316}}
test binary-59.12 {Tcl_BinaryObjCmd: scan} {
    unset -nocomplain arg1
    set arg1 foo
    list [binary scan \x52 r1 arg1] $arg1
} {0 foo}
test binary-59.13 {Tcl_BinaryObjCmd: scan} -setup {
    unset -nocomplain arg1
} -returnCodes error -body {
    set arg1 1
    binary scan \x3f\xcc\xcc\xcd r1 arg1(a)
} -result {can't set "arg1(a)": variable isn't array}
test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}
test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian {
    unset -nocomplain arg1 arg2
    set arg1 foo
    set arg2 bar
    list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2
} {2 {1.600000023841858 3.4000000953674316} 5}

test binary-60.1 {[binary format] with NaN} -body {
    binary scan [binary format dqQfrR NaN NaN NaN NaN NaN NaN] dqQfrR \
	v1 v2 v3 v4 v5 v6
    list $v1 $v2 $v3 $v4 $v5 $v6
} -match regexp -result {NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))? NaN(\([[:xdigit:]]+\))?}

# scan m
test binary-61.1 {Tcl_BinaryObjCmd: scan wide int} bigEndian {
    binary scan HelloTcl m x
    set x
} 5216694956358656876
test binary-61.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian {
    binary scan lcTolleH m x
    set x
} 5216694956358656876
test binary-61.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian {
    binary scan [binary format w [expr {wide(3) << 31}]] m x
    set x
} 6442450944
test binary-61.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian {
    binary scan [binary format W [expr {wide(3) << 31}]] m x
    set x
} 6442450944

# scan/format infinities

test binary-62.1 {infinity} ieeeFloatingPoint {
    binary scan [binary format q Infinity] w w
    format 0x%016lx $w
} 0x7ff0000000000000
test binary-62.2 {infinity} ieeeFloatingPoint {
    binary scan [binary format q -Infinity] w w
    format 0x%016lx $w
} 0xfff0000000000000
test binary-62.3 {infinity} ieeeFloatingPoint {
    binary scan [binary format q Inf] w w
    format 0x%016lx $w
} 0x7ff0000000000000
test binary-62.4 {infinity} ieeeFloatingPoint {
    binary scan [binary format q -Infinity] w w
    format 0x%016lx $w
} 0xfff0000000000000
test binary-62.5 {infinity} ieeeFloatingPoint {
    binary scan [binary format w 0x7ff0000000000000] q d
    set d
} Inf
test binary-62.6 {infinity} ieeeFloatingPoint {
    binary scan [binary format w 0xfff0000000000000] q d
    set d
} -Inf

# scan/format Not-a-Number

test binary-63.1 {NaN} ieeeFloatingPoint {
    binary scan [binary format q NaN] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff0000000000000
test binary-63.2 {NaN} ieeeFloatingPoint {
    binary scan [binary format q -NaN] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0xfff0000000000000
test binary-63.3 {NaN} ieeeFloatingPoint {
    binary scan [binary format q NaN(3123456789aBc)] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff3123456789abc
test binary-63.4 {NaN} ieeeFloatingPoint {
    binary scan [binary format q {NaN( 3123456789aBc)}] w w
    format 0x%016lx [expr {$w & 0xfff3ffffffffffff}]
} 0x7ff3123456789abc

# Make sure TclParseNumber() rejects invalid nan-hex formats [Bug 3402540]
test binary-63.5 {NaN} -constraints ieeeFloatingPoint -body {
    binary format q Nan(
} -returnCodes error -match glob -result {expected floating-point number*}
test binary-63.6 {NaN} -constraints ieeeFloatingPoint -body {
    binary format q Nan()
} -returnCodes error -match glob -result {expected floating-point number*}
test binary-63.7 {NaN} -constraints ieeeFloatingPoint -body {
    binary format q Nan(g)
} -returnCodes error -match glob -result {expected floating-point number*}
test binary-63.8 {NaN} -constraints ieeeFloatingPoint -body {
    binary format q Nan(1,2)
} -returnCodes error -match glob -result {expected floating-point number*}
test binary-63.9 {NaN} -constraints ieeeFloatingPoint -body {
    binary format q Nan(1234567890abcd)
} -returnCodes error -match glob -result {expected floating-point number*}

test binary-64.1 {NaN} -constraints ieeeFloatingPoint -body {
    binary scan [binary format w 0x7ff8000000000000] q d
    set d
} -match glob -result NaN*
test binary-64.2 {NaN} -constraints ieeeFloatingPoint -body {
    binary scan [binary format w 0x7ff0123456789aBc] q d
    set d
} -match glob -result NaN(*123456789abc)

test binary-65.1 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fcfffffffffffff] q d
    set d
} 0.24999999999999997
test binary-65.2 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fd0000000000000] q d
    set d
} 0.25
test binary-65.3 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fdfffffffffffff] q d
    set d
} 0.49999999999999994
test binary-65.4 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fe0000000000000] q d
    set d
} 0.5
test binary-65.5 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x3fffffffffffffff] q d
    set d
} 1.9999999999999998
test binary-65.6 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x4000000000000000] q d
    set d
} 2.0
test binary-65.7 {smallest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x434fffffffffffff] q d
    set d
} 18014398509481982.0
test binary-65.8 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x4350000000000000] q d
    set d
} 18014398509481984.0
test binary-65.9 {largest significand} ieeeFloatingPoint {
    binary scan [binary format w 0x4350000000000001] q d
    set d
} 18014398509481988.0

test binary-70.1 {binary encode hex} -body {
    binary encode hex
} -returnCodes error -match glob -result "wrong # args: *"
test binary-70.2 {binary encode hex} -body {
    binary encode hex a
} -result {61}
test binary-70.3 {binary encode hex} -body {
    binary encode hex {}
} -result {}
test binary-70.4 {binary encode hex} -body {
    binary encode hex [string repeat a 20]
} -result [string repeat 61 20]
test binary-70.5 {binary encode hex} -body {
    binary encode hex \0\1\2\3\4\0\1\2\3\4
} -result {00010203040001020304}

test binary-71.1 {binary decode hex} -body {
    binary decode hex
} -returnCodes error -match glob -result "wrong # args: *"
test binary-71.2 {binary decode hex} -body {
    binary decode hex 61
} -result {a}
test binary-71.3 {binary decode hex} -body {
    binary decode hex {}
} -result {}
test binary-71.4 {binary decode hex} -body {
    binary decode hex [string repeat 61 20]
} -result [string repeat a 20]
test binary-71.5 {binary decode hex} -body {
    binary decode hex 00010203040001020304
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
    binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
    binary decode hex "61\n\n\n61"
} -result {aa}
test binary-71.8 {binary decode hex} -body {
    binary decode hex -strict "61 61"
} -returnCodes error -result {invalid hexadecimal digit " " at position 2}
test binary-71.9 {binary decode hex} -body {
    set r [binary decode hex "6"]
    list [string length $r] $r
} -result {0 {}}
test binary-71.10 {binary decode hex} -body {
    string length [binary decode hex " "]
} -result 0

test binary-72.1 {binary encode base64} -body {
    binary encode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-72.2 {binary encode base64} -body {
    binary encode base64 abc
} -result {YWJj}
test binary-72.3 {binary encode base64} -body {
    binary encode base64 {}
} -result {}
test binary-72.4 {binary encode base64} -body {
    binary encode base64 [string repeat abc 20]
} -result [string repeat YWJj 20]
test binary-72.5 {binary encode base64} -body {
    binary encode base64 \0\1\2\3\4\0\1\2\3
} -result {AAECAwQAAQID}
test binary-72.6 {binary encode base64} -body {
    binary encode base64 \0
} -result {AA==}
test binary-72.7 {binary encode base64} -body {
    binary encode base64 \0\0
} -result {AAA=}
test binary-72.8 {binary encode base64} -body {
    binary encode base64 \0\0\0
} -result {AAAA}
test binary-72.9 {binary encode base64} -body {
    binary encode base64 \0\0\0\0
} -result {AAAAAA==}
test binary-72.10 {binary encode base64} -body {
    binary encode base64 -maxlen 0 -wrapchar : abcabcabc
} -result {YWJjYWJjYWJj}
test binary-72.11 {binary encode base64} -body {
    binary encode base64 -maxlen 1 -wrapchar : abcabcabc
} -result {Y:W:J:j:Y:W:J:j:Y:W:J:j}
test binary-72.12 {binary encode base64} -body {
    binary encode base64 -maxlen 2 -wrapchar : abcabcabc
} -result {YW:Jj:YW:Jj:YW:Jj}
test binary-72.13 {binary encode base64} -body {
    binary encode base64 -maxlen 3 -wrapchar : abcabcabc
} -result {YWJ:jYW:JjY:WJj}
test binary-72.14 {binary encode base64} -body {
    binary encode base64 -maxlen 4 -wrapchar : abcabcabc
} -result {YWJj:YWJj:YWJj}
test binary-72.15 {binary encode base64} -body {
    binary encode base64 -maxlen 5 -wrapchar : abcabcabc
} -result {YWJjY:WJjYW:Jj}
test binary-72.16 {binary encode base64} -body {
    binary encode base64 -maxlen 6 -wrapchar : abcabcabc
} -result {YWJjYW:JjYWJj}
test binary-72.17 {binary encode base64} -body {
    binary encode base64 -maxlen 7 -wrapchar : abcabcabc
} -result {YWJjYWJ:jYWJj}
test binary-72.18 {binary encode base64} -body {
    binary encode base64 -maxlen 8 -wrapchar : abcabcabc
} -result {YWJjYWJj:YWJj}
test binary-72.19 {binary encode base64} -body {
    binary encode base64 -maxlen 9 -wrapchar : abcabcabc
} -result {YWJjYWJjY:WJj}
test binary-72.20 {binary encode base64} -body {
    binary encode base64 -maxlen 10 -wrapchar : abcabcabc
} -result {YWJjYWJjYW:Jj}
test binary-72.21 {binary encode base64} -body {
    binary encode base64 -maxlen 11 -wrapchar : abcabcabc
} -result {YWJjYWJjYWJ:j}
test binary-72.22 {binary encode base64} -body {
    binary encode base64 -maxlen 12 -wrapchar : abcabcabc
} -result {YWJjYWJjYWJj}
test binary-72.23 {binary encode base64} -body {
    binary encode base64 -maxlen 13 -wrapchar : abcabcabc
} -result {YWJjYWJjYWJj}
test binary-72.24 {binary encode base64} -body {
    binary encode base64 -maxlen 60 -wrapchar : abcabcabc
} -result {YWJjYWJjYWJj}
test binary-72.25 {binary encode base64} -body {
    binary encode base64 -maxlen 2 -wrapchar * abcabcabc
} -result {YW*Jj*YW*Jj*YW*Jj}
test binary-72.26 {binary encode base64} -body {
    binary encode base64 -maxlen 6 -wrapchar -*- abcabcabc
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
    binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
    binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}

test binary-73.1 {binary decode base64} -body {
    binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
    binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
    binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
    binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
test binary-73.5 {binary encode base64} -body {
    binary decode base64 AAECAwQAAQID
} -result "\0\1\2\3\4\0\1\2\3"
test binary-73.6 {binary encode base64} -body {
    binary decode base64 AA==
} -result "\0"
test binary-73.7 {binary encode base64} -body {
    binary decode base64 AAA=
} -result "\0\0"
test binary-73.8 {binary encode base64} -body {
    binary decode base64 AAAA
} -result "\0\0\0"
test binary-73.9 {binary encode base64} -body {
    binary decode base64 AAAAAA==
} -result "\0\0\0\0"
test binary-73.10 {binary decode base64} -body {
    set s "[string repeat YWJj 10]\n[string repeat YWJj 10]"
    binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.11 {binary decode base64} -body {
    set s "[string repeat YWJj 10]\n    [string repeat YWJj 10]"
    binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.12 {binary decode base64} -body {
    binary decode base64 -strict ":YWJj"
} -returnCodes error -match glob -result {invalid base64 character ":" at position 0}
test binary-73.13 {binary decode base64} -body {
    set s "[string repeat YWJj 10]:[string repeat YWJj 10]"
    binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character ":" at position 40}
test binary-73.14 {binary decode base64} -body {
    set s "[string repeat YWJj 10]\n    [string repeat YWJj 10]"
    binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.20 {binary decode base64} -body {
    set r [binary decode base64 Y]
    list [string length $r] $r
} -result {0 {}}
test binary-73.21 {binary decode base64} -body {
    set r [binary decode base64 YW]
    list [string length $r] $r
} -result {1 a}
test binary-73.22 {binary decode base64} -body {
    set r [binary decode base64 YWJ]
    list [string length $r] $r
} -result {2 ab}
test binary-73.23 {binary decode base64} -body {
    set r [binary decode base64 YWJj]
    list [string length $r] $r
} -result {3 abc}
test binary-73.24 {binary decode base64} -body {
    string length [binary decode base64 " "]
} -result 0

test binary-74.1 {binary encode uuencode} -body {
    binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
    binary encode uuencode abc
} -result {86)C}
test binary-74.3 {binary encode uuencode} -body {
    binary encode uuencode {}
} -result {}
test binary-74.4 {binary encode uuencode} -body {
    binary encode uuencode [string repeat abc 20]
} -result [string repeat 86)C 20]
test binary-74.5 {binary encode uuencode} -body {
    binary encode uuencode \0\1\2\3\4\0\1\2\3
} -result "``\$\"`P0``0(#"
test binary-74.6 {binary encode uuencode} -body {
    binary encode uuencode \0
} -result {````}
test binary-74.7 {binary encode uuencode} -body {
    binary encode uuencode \0\0
} -result {````}
test binary-74.8 {binary encode uuencode} -body {
    binary encode uuencode \0\0\0
} -result {````}
test binary-74.9 {binary encode uuencode} -body {
    binary encode uuencode \0\0\0\0
} -result {````````}
test binary-74.10 {binary encode uuencode} -body {
    binary encode uuencode -maxlen 0 -wrapchar | abcabcabc
} -result {86)C86)C86)C}
test binary-74.11 {binary encode uuencode} -body {
    binary encode uuencode -maxlen 1 -wrapchar | abcabcabc
} -result {8|6|)|C|8|6|)|C|8|6|)|C}

test binary-75.1 {binary decode uuencode} -body {
    binary decode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-75.2 {binary decode uuencode} -body {
    binary decode uuencode 86)C
} -result {abc}
test binary-75.3 {binary decode uuencode} -body {
    binary decode uuencode {}
} -result {}
test binary-75.4 {binary decode uuencode} -body {
    binary decode uuencode [string repeat "86)C" 20]
} -result [string repeat abc 20]
test binary-75.5 {binary decode uuencode} -body {
    binary decode uuencode "``\$\"`P0``0(#"
} -result "\0\1\2\3\4\0\1\2\3"
test binary-75.6 {binary decode uuencode} -body {
    string length [binary decode uuencode {`}]
} -result 0
test binary-75.7 {binary decode uuencode} -body {
    string length [binary decode uuencode {``}]
} -result 1
test binary-75.8 {binary decode uuencode} -body {
    string length [binary decode uuencode {```}]
} -result 2
test binary-75.9 {binary decode uuencode} -body {
    string length [binary decode uuencode {````}]
} -result 3
test binary-75.10 {binary decode uuencode} -body {
    set s "[string repeat 86)C 10]\n[string repeat 86)C 10]"
    binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
    set s "[string repeat 86)C 10]\n    [string repeat 86)C 10]"
    binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
    binary decode uuencode -strict "|86)C"
} -returnCodes error -match glob -result {invalid uuencode character "|" at position 0}
test binary-75.13 {binary decode uuencode} -body {
    set s "[string repeat 86)C 10]|[string repeat 86)C 10]"
    binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40}
test binary-75.14 {binary decode uuencode} -body {
    set s "[string repeat 86)C 10]\n    [string repeat 86)C 10]"
    binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character *}
test binary-75.20 {binary decode uuencode} -body {
    set r [binary decode uuencode 8]
    list [string length $r] $r
} -result {0 {}}
test binary-75.21 {binary decode uuencode} -body {
    set r [binary decode uuencode 86]
    list [string length $r] $r
} -result {1 a}
test binary-75.22 {binary decode uuencode} -body {
    set r [binary decode uuencode 86)]
    list [string length $r] $r
} -result {2 ab}
test binary-75.23 {binary decode uuencode} -body {
    set r [binary decode uuencode 86)C]
    list [string length $r] $r
} -result {3 abc}
test binary-75.24 {binary decode uuencode} -body {
    set s "04)\# "
    binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
    set s "04)\#z"
    binary decode uuencode $s
} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4}
test binary-75.26 {binary decode uuencode} -body {
    string length [binary decode uuencode " "]
} -result 0

test binary-76.1 {binary string appending growth algorithm} unix {
    # Create zero-length byte array first
    set f [open /dev/null rb]
    chan configure $f -blocking 0
    set str [read $f 2]
    close $f
    # Append to it
    string length [append str [binary format a* foo]]
} 3
test binary-76.2 {binary string appending growth algorithm} win {
    # Create zero-length byte array first
    set f [open NUL rb]
    chan configure $f -blocking 0
    set str [read $f 2]
    close $f
    # Append to it
    string length [append str [binary format a* foo]]
} 3

# ----------------------------------------------------------------------
# cleanup

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: