Subversion Repositories or1k

# This file contains tests for the file tclCompile.c.

#

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

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

# RCS: @(#) $Id: compile.test,v 1.1.1.1 2002-01-16 10:25:35 markom Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

# The following tests are very incomplete, although the rest of the

# test suite covers this file fairly well.

catch {rename p ""}

catch {namespace delete test_ns_compile}

catch {unset x}

catch {unset y}

catch {unset a}

test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} {

    catch {namespace delete test_ns_compile}

    catch {unset x}

    set x 123

    namespace eval test_ns_compile {

        proc set {args} {

            global x

            lappend x test_ns_compile::set

        }

        proc p {} {

            set 0

        }

    }

    list [test_ns_compile::p] [set x]

} {{123 test_ns_compile::set} {123 test_ns_compile::set}}

test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {

    proc p {x} {info commands 3m}

    list [catch {p} msg] $msg

} {1 {no value given for parameter "x" to "p"}}

test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} {

    catch {unset x}

    set x 123

    list $::x [expr {[lsearch -exact [info globals] x] != 0}]

} {123 1}

test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} {

    catch {unset y}

    proc p {} {

        set ::y 789

        return $::y

    }

    list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]

} {789 789 1}

test compile-2.3 {TclCompileDollarVar: global array name with ::s} {

    catch {unset a}

    set ::a(1) 2

    list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}]

} {2 3 3 1}

test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} {

    catch {unset a}

    proc p {} {

        set ::a(1) 1

        return $::a($::a(1))

    }

    list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]

} {1 1 1}

test compile-3.2 {TclCompileCatchCmd: non-local variables} {

    set ::foo 1

    proc catch-test {} {

        catch {set x 3} ::foo

    }

    catch-test

    set ::foo

} 3

test compile-1.16 {TclCompileForCmd: command substituted test expression} {

    set i 0

    set j 0

    # Should be "forever"

    for {} [expr $i < 3] {} {

        set j [incr i]

        if {$j > 3} break

    }

    set j

} {4}

test compile-3.1 {TclCompileForeachCmd: exception stack} {

    proc foreach-exception-test {} {

        foreach array(index) [list 1 2 3] break

        foreach array(index) [list 1 2 3] break

        foreach scalar [list 1 2 3] break

    }

    list [catch foreach-exception-test result] $result

} {0 {}}

test compile-3.2 {TclCompileForeachCmd: non-local variables} {

    set ::foo 1

    proc foreach-test {} {

        foreach ::foo {1 2 3} {}

    }

    foreach-test

    set ::foo

} 3

test compile-4.1 {TclCompileSetCmd: global scalar names with ::s} {

    catch {unset x}

    catch {unset y}

    set x 123

    proc p {} {

        set ::y 789

        return $::y

    }

    list $::x [expr {[lsearch -exact [info globals] x] != 0}] \

         [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]

} {123 1 789 789 1}

test compile-4.2 {TclCompileSetCmd: global array names with ::s} {

    catch {unset a}

    set ::a(1) 2

    proc p {} {

        set ::a(1) 1

        return $::a($::a(1))

    }

    list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]

} {2 1 3 3 1}

test compile-4.3 {TclCompileSetCmd: namespace var names with ::s} {

    catch {namespace delete test_ns_compile}

    catch {unset x}

    namespace eval test_ns_compile {

        variable v hello

        variable arr

        set ::x $::test_ns_compile::v

        set ::test_ns_compile::arr(1) 123

    }

    list $::x $::test_ns_compile::arr(1)

} {hello 123}

test compile-1.15 {TclCompileWhileCmd: command substituted test expression} {

    set i 0

    set j 0

    # Should be "forever"

    while [expr $i < 3] {

        set j [incr i]

        if {$j > 3} break

    }

    set j

} {4}

test compile-5.1 {CollectArgInfo: binary data} {

    list [catch "string length \000foo" msg] $msg

} {0 4}

test compile-5.2 {CollectArgInfo: binary data} {

    list [catch "string length foo\000" msg] $msg

} {0 4}

test compile-5.3 {CollectArgInfo: handle "]" at end of command properly} {

    set x ]

} {]}

test compile-6.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {

    proc p {} {

        set x {}

        eval $x

        append x { }

        eval $x

    }

    p

} {}

catch {rename p ""}

catch {namespace delete test_ns_compile}

catch {unset x}

catch {unset y}

catch {unset a}

return