diff options
Diffstat (limited to 'trunk/Examples/test-suite/tcl')
20 files changed, 837 insertions, 0 deletions
diff --git a/trunk/Examples/test-suite/tcl/Makefile.in b/trunk/Examples/test-suite/tcl/Makefile.in new file mode 100644 index 000000000..49d2a7826 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/Makefile.in @@ -0,0 +1,57 @@ +####################################################################### +# Makefile for tcl test-suite +####################################################################### + +LANGUAGE = tcl +TCLSH = tclsh +SCRIPTSUFFIX = _runme.tcl +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +top_builddir = @top_builddir@ + +CPP_TEST_CASES += \ + primitive_types \ + li_cstring \ + li_cwstring + +C_TEST_CASES += \ + li_cstring \ + li_cwstring + +include $(srcdir)/../common.mk + +# Overridden variables here +# none! + +# Custom tests - tests with additional commandline options +# none! + +# Rules for the different types of tests +%.cpptest: + $(setup) + +$(swig_and_compile_cpp) + $(run_testcase) + +%.ctest: + $(setup) + +$(swig_and_compile_c) + $(run_testcase) + +%.multicpptest: + $(setup) + +$(swig_and_compile_multi_cpp) + $(run_testcase) + +# Runs the testcase. A testcase is only run if +# a file is found which has _runme.tcl appended after the testcase name. +run_testcase = \ + if [ -f $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX) ]; then \ + env LD_LIBRARY_PATH=.:$$LD_LIBRARY_PATH $(RUNTOOL) $(TCLSH) $(srcdir)/$(SCRIPTPREFIX)$*$(SCRIPTSUFFIX); \ + fi + +# Clean +%.clean: + + +clean: + $(MAKE) -f $(top_builddir)/$(EXAMPLES)/Makefile tcl_clean diff --git a/trunk/Examples/test-suite/tcl/README b/trunk/Examples/test-suite/tcl/README new file mode 100644 index 000000000..c36c3aa9a --- /dev/null +++ b/trunk/Examples/test-suite/tcl/README @@ -0,0 +1,4 @@ +See ../README for common README file. + +Any testcases which have _runme.tcl appended after the testcase name will be detected and run. + diff --git a/trunk/Examples/test-suite/tcl/bools_runme.tcl b/trunk/Examples/test-suite/tcl/bools_runme.tcl new file mode 100644 index 000000000..582b8121f --- /dev/null +++ b/trunk/Examples/test-suite/tcl/bools_runme.tcl @@ -0,0 +1,73 @@ + +if [ catch { load ./bools[info sharedlibextension] bools} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +# bool constant check +if {$constbool != 0} { + puts stderr "Runtime test 1 failed" + exit 1 +} + +# bool variables check +if {$bool1 != 1} { + puts stderr "Runtime test 2 failed" + exit 1 +} + +if {$bool2 != 0} { + puts stderr "Runtime test 3 failed" + exit 1 +} + +if { [ value $pbool ] != $bool1} { + puts stderr "Runtime test 4 failed" + exit 1 +} + +if { [ value $rbool ] != $bool2} { + puts stderr "Runtime test 5 failed" + exit 1 +} + +if { [ value $const_pbool ] != $bool1} { + puts stderr "Runtime test 6 failed" + exit 1 +} + +if { $const_rbool != $bool2} { + puts stderr "Runtime test 7 failed" + exit 1 +} + +# bool functions check +if { [ bo 0 ] != 0} { + puts stderr "Runtime test 8 failed" + exit 1 +} + +if { [ bo 1 ] != 1} { + puts stderr "Runtime test 9 failed" + exit 1 +} + +if { [ value [ rbo $rbool ] ] != [ value $rbool ]} { + puts stderr "Runtime test 10 failed" + exit 1 +} + +if { [ value [ pbo $pbool ] ] != [ value $pbool ]} { + puts stderr "Runtime test 11 failed" + exit 1 +} + +if { [ const_rbo $const_rbool ] != $const_rbool } { + puts stderr "Runtime test 12 failed" + exit 1 +} + +if { [ value [ const_pbo $const_pbool ] ] != [ value $const_pbool ]} { + puts stderr "Runtime test 13 failed" + exit 1 +} + diff --git a/trunk/Examples/test-suite/tcl/clientdata_prop_runme.tcl b/trunk/Examples/test-suite/tcl/clientdata_prop_runme.tcl new file mode 100644 index 000000000..2ac993fad --- /dev/null +++ b/trunk/Examples/test-suite/tcl/clientdata_prop_runme.tcl @@ -0,0 +1,88 @@ + +if [ catch { load ./clientdata_prop_b[info sharedlibextension] clientdata_prop_b} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" + exit 1 +} +if [ catch { load ./clientdata_prop_a[info sharedlibextension] clientdata_prop_a} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" + exit 1 +} + +A a +test_A a +test_tA a +test_t2A a +test_t3A a +a fA + +B b +test_A b +test_tA b +test_t2A b +test_t3A b +test_B b +b fA +b fB + +C c +test_A c +test_tA c +test_t2A c +test_t3A c +test_C c +c fA +c fC + +D d +test_A d +test_tA d +test_t2A d +test_t3A d +test_D d +test_tD d +test_t2D d +d fA +d fD + +set a2 [new_tA] +test_A $a2 +test_tA $a2 +test_t2A $a2 +test_t3A $a2 +$a2 fA + +set a3 [new_t2A] +test_A $a3 +test_tA $a3 +test_t2A $a3 +test_t3A $a3 +$a3 fA + +set a4 [new_t3A] +test_A $a4 +test_tA $a4 +test_t2A $a4 +test_t3A $a4 +$a4 fA + +set d2 [new_tD] +test_A $d2 +test_tA $d2 +test_t2A $d2 +test_t3A $d2 +test_D $d2 +test_tD $d2 +test_t2D $d2 +$d2 fA +$d2 fD + +set d3 [new_t2D] +test_A $d3 +test_tA $d3 +test_t2A $d3 +test_t3A $d3 +test_D $d3 +test_tD $d3 +test_t2D $d3 +$d3 fA +$d3 fD diff --git a/trunk/Examples/test-suite/tcl/disown_runme.tcl b/trunk/Examples/test-suite/tcl/disown_runme.tcl new file mode 100644 index 000000000..d6647c037 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/disown_runme.tcl @@ -0,0 +1,16 @@ + +# This is the union runtime testcase. It ensures that values within a +# union embedded within a struct can be set and read correctly. + +if [ catch { load ./disown[info sharedlibextension] disown} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +set x 0 +while {$x<100} { + set a [new_A] + B b + b acquire $a + incr x +} + diff --git a/trunk/Examples/test-suite/tcl/enum_thorough_runme.tcl b/trunk/Examples/test-suite/tcl/enum_thorough_runme.tcl new file mode 100644 index 000000000..d4cc1995a --- /dev/null +++ b/trunk/Examples/test-suite/tcl/enum_thorough_runme.tcl @@ -0,0 +1,9 @@ + +if [ catch { load ./enum_thorough[info sharedlibextension] enum_thorough} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +if { [speedTest0 $SpeedClass_slow] != $SpeedClass_slow } { puts stderr "speedTest0 failed" } +if { [speedTest4 $SpeedClass_slow] != $SpeedClass_slow } { puts stderr "speedTest4 failed" } +if { [speedTest5 $SpeedClass_slow] != $SpeedClass_slow } { puts stderr "speedTest5 failed" } + diff --git a/trunk/Examples/test-suite/tcl/import_nomodule_runme.tcl b/trunk/Examples/test-suite/tcl/import_nomodule_runme.tcl new file mode 100644 index 000000000..ead6c3fbe --- /dev/null +++ b/trunk/Examples/test-suite/tcl/import_nomodule_runme.tcl @@ -0,0 +1,4 @@ + +if [ catch { load ./import_nomodule[info sharedlibextension] import_nomodule} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} diff --git a/trunk/Examples/test-suite/tcl/imports_runme.tcl b/trunk/Examples/test-suite/tcl/imports_runme.tcl new file mode 100644 index 000000000..85abe49ed --- /dev/null +++ b/trunk/Examples/test-suite/tcl/imports_runme.tcl @@ -0,0 +1,19 @@ + +# This is the imports runtime testcase. + +if [ catch { load ./imports_b[info sharedlibextension] imports_b} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" + exit 1 +} +if [ catch { load ./imports_a[info sharedlibextension] imports_a} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +exit 1 +} + +set x [new_B] +A_hello $x +if [ catch { $x nonexistant } ] { +} else { + puts stderr "nonexistant method did not throw exception\n" + exit 1 +} diff --git a/trunk/Examples/test-suite/tcl/li_std_string_runme.tcl b/trunk/Examples/test-suite/tcl/li_std_string_runme.tcl new file mode 100644 index 000000000..333c1f1be --- /dev/null +++ b/trunk/Examples/test-suite/tcl/li_std_string_runme.tcl @@ -0,0 +1,21 @@ + +if [ catch { load ./li_std_string[info sharedlibextension] li_std_string} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +Structure s +if {"[s cget -MemberString2]" != "member string 2"} { error "bad string map"} +s configure -MemberString2 "hello" +if {"[s cget -MemberString2]" != "hello"} { error "bad string map"} + +if {"[s cget -ConstMemberString]" != "const member string"} { error "bad string map"} + +if {"$GlobalString2" != "global string 2"} { error "bad string map"} +if {"$Structure_StaticMemberString2" != "static member string 2"} { error "bad string map"} + +set GlobalString2 "hello" +if {"$GlobalString2" != "hello"} { error "bad string map"} + +set Structure_StaticMemberString2 "hello" +if {"$Structure_StaticMemberString2" != "hello"} { error "bad string map"} diff --git a/trunk/Examples/test-suite/tcl/member_pointer_runme.tcl b/trunk/Examples/test-suite/tcl/member_pointer_runme.tcl new file mode 100644 index 000000000..e4d099163 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/member_pointer_runme.tcl @@ -0,0 +1,46 @@ +# Example using pointers to member functions + +if [ catch { load ./member_pointer[info sharedlibextension] member_pointer} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +proc check {what expected actual} { + if {$expected != $actual } { + error "Failed: $what , Expected: $expected , Actual: $actual" + } +} +# Get the pointers + +set area_pt [ areapt ] +set perim_pt [ perimeterpt ] + +# Create some objects + +set s [Square -args 10] + +# Do some calculations + +check "Square area " 100.0 [do_op $s $area_pt] +check "Square perim" 40.0 [do_op $s $perim_pt] + +set memberPtr $areavar +set memberPtr $perimetervar + +# Try the variables +check "Square area " 100.0 [do_op $s $areavar] +check "Square perim" 40.0 [do_op $s $perimetervar] + +# Modify one of the variables +set areavar $perim_pt + +check "Square perimeter" 40.0 [do_op $s $areavar] + +# Try the constants + +set memberPtr $AREAPT +set memberPtr $PERIMPT +set memberPtr $NULLPT + +check "Square area " 100.0 [do_op $s $AREAPT] +check "Square perim" 40.0 [do_op $s $PERIMPT] + diff --git a/trunk/Examples/test-suite/tcl/newobject1_runme.tcl b/trunk/Examples/test-suite/tcl/newobject1_runme.tcl new file mode 100644 index 000000000..da6ff6679 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/newobject1_runme.tcl @@ -0,0 +1,28 @@ +if [ catch { load ./newobject1[info sharedlibextension] newobject1} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +set foo1 [Foo_makeFoo] +if {[Foo_fooCount] != 1} { + puts stderr "newobject1 test 1 failed" + exit 1 +} + +set foo2 [$foo1 makeMore] +if {[Foo_fooCount] != 2} { + puts stderr "newobject1 test 2 failed" + exit 1 +} + +# Disable test while we solve the problem of premature object deletion +#$foo1 -delete +#if {[Foo_fooCount] != 1} { +# puts stderr "newobject1 test 3 failed" +# exit 1 +#} +# +#$foo2 -delete +#if {[Foo_fooCount] != 0} { +# puts stderr "newobject1 test 4 failed" +# exit 1 +#} diff --git a/trunk/Examples/test-suite/tcl/newobject2_runme.tcl b/trunk/Examples/test-suite/tcl/newobject2_runme.tcl new file mode 100644 index 000000000..18d23af33 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/newobject2_runme.tcl @@ -0,0 +1,27 @@ +if [ catch { load ./newobject2[info sharedlibextension] newobject2} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +set foo1 [makeFoo] +if {[fooCount] != 1} { + puts stderr "newobject2 test 1 failed" + exit 1 +} + +set foo2 [makeFoo] +if {[fooCount] != 2} { + puts stderr "newobject2 test 2 failed" + exit 1 +} + +#$foo1 -delete +#if {[fooCount] != 1} { +# puts stderr "newobject2 test 3 failed" +# exit 1 +#} + +#$foo2 -delete +#if {[fooCount] != 0} { +# puts stderr "newobject2 test 4 failed" +# exit 1 +#} diff --git a/trunk/Examples/test-suite/tcl/overload_copy_runme.tcl b/trunk/Examples/test-suite/tcl/overload_copy_runme.tcl new file mode 100644 index 000000000..46d7058d5 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/overload_copy_runme.tcl @@ -0,0 +1,12 @@ + +if [ catch { load ./overload_copy[info sharedlibextension] overload_copy} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +Foo f +Foo g [f cget -this] + + + + + diff --git a/trunk/Examples/test-suite/tcl/overload_simple_runme.tcl b/trunk/Examples/test-suite/tcl/overload_simple_runme.tcl new file mode 100644 index 000000000..6b65ccc90 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/overload_simple_runme.tcl @@ -0,0 +1,166 @@ + +if [ catch { load ./overload_simple[info sharedlibextension] overload_simple} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +set f [new_Foo] +set b [new_Bar] +set v [malloc_void 32] + +set x [foo 3] +if {$x != "foo:int"} { + puts stderr "foo(int) test failed $x" + exit 1 +} + +set x [foo 3.4] +if {$x != "foo:double"} { + puts stderr "foo(double) test failed" + exit 1 +} + +set x [foo hello] +if {$x != "foo:char *"} { + puts stderr "foo(char *) test failed" + exit 1 +} + +set x [foo $f] +if {$x != "foo:Foo *"} { + puts stderr "foo(Foo *) test failed" + exit 1 +} + +set x [foo $b] +if {$x != "foo:Bar *"} { + puts stderr "foo(Bar *) test failed" + exit 1 +} + +set x [foo $v] +if {$x != "foo:void *"} { + puts stderr "foo(void *) test failed" + exit 1 +} + +Spam s + +set x [s foo 3] +if {$x != "foo:int"} { + puts stderr "Spam::foo(int) test failed" + exit 1 +} + +set x [s foo 3.4] +if {$x != "foo:double"} { + puts stderr "Spam::foo(double) test failed" + exit 1 +} + +set x [s foo hello] +if {$x != "foo:char *"} { + puts stderr "Spam::foo(char *) test failed" + exit 1 +} + +set x [s foo $f] +if {$x != "foo:Foo *"} { + puts stderr "Spam::foo(Foo *) test failed" + exit 1 +} + +set x [s foo $b] +if {$x != "foo:Bar *"} { + puts stderr "Spam::foo(Bar *) test failed" + exit 1 +} + +set x [s foo $v] +if {$x != "foo:void *"} { + puts stderr "Spam::foo(void *) test failed" + exit 1 +} + + +set x [Spam_bar 3] +if {$x != "bar:int"} { + puts stderr "Spam::bar(int) test failed" + exit 1 +} + +set x [Spam_bar 3.4] +if {$x != "bar:double"} { + puts stderr "Spam::bar(double) test failed" + exit 1 +} + +set x [Spam_bar hello] +if {$x != "bar:char *"} { + puts stderr "Spam::bar(char *) test failed" + exit 1 +} + +set x [Spam_bar $f] +if {$x != "bar:Foo *"} { + puts stderr "Spam::bar(Foo *) test failed" + exit 1 +} + +set x [Spam_bar $b] +if {$x != "bar:Bar *"} { + puts stderr "Spam::bar(Bar *) test failed" + exit 1 +} + +set x [Spam_bar $v] +if {$x != "bar:void *"} { + puts stderr "Spam::bar(void *) test failed" + exit 1 +} + +Spam s +set x [s cget -type] +if {$x != "none"} { + puts stderr "Spam() test failed" +} + +Spam s 3 +set x [s cget -type] +if {$x != "int"} { + puts stderr "Spam(int) test failed" +} + +Spam s 3.4 +set x [s cget -type] +if {$x != "double"} { + puts stderr "Spam(double) test failed" +} + +Spam s hello +set x [s cget -type] +if {$x != "char *"} { + puts stderr "Spam(char *) test failed" +} + +Spam s $f +set x [s cget -type] +if {$x != "Foo *"} { + puts stderr "Spam(Foo *) test failed" +} + +Spam s $b +set x [s cget -type] +if {$x != "Bar *"} { + puts stderr "Spam(Bar *) test failed" +} + +Spam s $v +set x [s cget -type] +if {$x != "void *"} { + puts stderr "Spam(void *) test failed" +} + +free_void $v + + + diff --git a/trunk/Examples/test-suite/tcl/primitive_ref_runme.tcl b/trunk/Examples/test-suite/tcl/primitive_ref_runme.tcl new file mode 100644 index 000000000..ab4e444d2 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/primitive_ref_runme.tcl @@ -0,0 +1,19 @@ +# Primitive ref testcase. Tests to make sure references to +# primitive types are passed by value + +if [ catch { load ./primitive_ref[info sharedlibextension] primitive_ref} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +if { [ref_int 3] != 3 } { puts stderr "ref_int failed" } +if { [ref_uint 3] != 3 } { puts stderr "ref_uint failed" } +if { [ref_short 3] != 3 } { puts stderr "ref_short failed" } +if { [ref_ushort 3] != 3 } { puts stderr "ref_ushort failed" } +if { [ref_long 3] != 3 } { puts stderr "ref_long failed" } +if { [ref_ulong 3] != 3 } { puts stderr "ref_ulong failed" } +if { [ref_schar 3] != 3 } { puts stderr "ref_schar failed" } +if { [ref_uchar 3] != 3 } { puts stderr "ref_uchar failed" } +if { [ref_float 3.5] != 3.5 } { puts stderr "ref_float failed" } +if { [ref_double 3.5] != 3.5 } { puts stderr "ref_double failed" } +if { [ref_char x] != "x" } { puts stderr "ref_char failed" } + diff --git a/trunk/Examples/test-suite/tcl/primitive_types_runme.tcl b/trunk/Examples/test-suite/tcl/primitive_types_runme.tcl new file mode 100644 index 000000000..fa4c46ba5 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/primitive_types_runme.tcl @@ -0,0 +1,33 @@ + +if [ catch { load ./primitive_types[info sharedlibextension] primitive_types} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +if {[val_int 10] != 10 } { error "bad int map" } +if {[val_schar 10] != 10 } { error "bad char map" } +if {[val_short 10] != 10 } { error "bad schar map" } + + +if [catch { val_schar 10000 } ] {} else { error "bad schar map" } +if [catch { val_uint -100 } ] {} else { error "bad uint map" } +if [catch { val_uchar -100 } ] {} else { error "bad uchar map" } + +if {[val_uint 10] != 10 } { error "bad uint map" } +if {[val_uchar 10] != 10 } { error "bad uchar map" } +if {[val_ushort 10] != 10 } { error "bad ushort map" } + + +if {[val_double 10] != 10 } { error "bad double map" } +if {[val_float 10] != 10 } { error "bad double map" } + + + +if [catch { val_float hello } ] {} else { error "bad double map" } + +if {[val_char c] != "c" } { error "bad char map" } +if {[val_char "c"] != "c" } { error "bad char map" } +if {[val_char 101] != "e" } { error "bad char map" } + + + diff --git a/trunk/Examples/test-suite/tcl/profiletest_runme.tcl b/trunk/Examples/test-suite/tcl/profiletest_runme.tcl new file mode 100644 index 000000000..087eea463 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/profiletest_runme.tcl @@ -0,0 +1,8 @@ +catch { load ./profiletest[info sharedlibextension] profiletest} + +set a [new_A] +set b [new_B] + +for {set i 0} {$i < 1000000} {incr i 1} { + set a [B_fn $b $a] +} diff --git a/trunk/Examples/test-suite/tcl/reference_global_vars_runme.tcl b/trunk/Examples/test-suite/tcl/reference_global_vars_runme.tcl new file mode 100644 index 000000000..bfd31a949 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/reference_global_vars_runme.tcl @@ -0,0 +1,108 @@ +if [ catch { load ./reference_global_vars[info sharedlibextension] reference_global_vars} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +# const class reference variable +if {[ [getconstTC ] cget -num] != 33 } { + puts stderr "test 1 failed" + exit 1 +} + +# primitive reference variables +set var_bool [createref_bool 0] +if {[value_bool $var_bool] != 0} { + puts stderr "test 2 failed" + exit 1 +} + +set var_bool [createref_bool 1] +if {[value_bool $var_bool] != 1} { + puts stderr "test 3 failed" + exit 1 +} + +set var_char [createref_char "w"] +if {[value_char $var_char] != "w"} { + puts stderr "test 4 failed" + exit 1 +} + +set var_unsigned_char [createref_unsigned_char 10] +if {[value_unsigned_char $var_unsigned_char] != 10} { + puts stderr "test 5 failed" + exit 1 +} + +set var_signed_char [createref_signed_char 10] +if {[value_signed_char $var_signed_char] != 10} { + puts stderr "test 6 failed" + exit 1 +} + +set var_short [createref_short 10] +if {[value_short $var_short] != 10} { + puts stderr "test 7 failed" + exit 1 +} + +set var_unsigned_short [createref_unsigned_short 10] +if {[value_unsigned_short $var_unsigned_short] != 10} { + puts stderr "test 8 failed" + exit 1 +} + +set var_int [createref_int 10] +if {[value_int $var_int] != 10} { + puts stderr "test 9 failed" + exit 1 +} + +set var_unsigned_int [createref_unsigned_int 10] +if {[value_unsigned_int $var_unsigned_int] != 10} { + puts stderr "test 10 failed" + exit 1 +} + +set var_long [createref_long 10] +if {[value_long $var_long] != 10} { + puts stderr "test 11 failed" + exit 1 +} + +set var_unsigned_long [createref_unsigned_long 10] +if {[value_unsigned_long $var_unsigned_long] != 10} { + puts stderr "test 12 failed" + exit 1 +} + +set var_long_long [createref_long_long 10] +if {[value_long_long $var_long_long] != 10} { + puts stderr "test 13 failed" + exit 1 +} + +set var_unsigned_long_long [createref_unsigned_long_long 10] +if {[value_unsigned_long_long $var_unsigned_long_long] != 10} { + puts stderr "test 14 failed" + exit 1 +} + +set var_float [createref_float 10.5] +if {[value_float $var_float] != 10.5} { + puts stderr "test 15 failed" + exit 1 +} + +set var_double [createref_double 10.5] +if {[value_double $var_double] != 10.5} { + puts stderr "test 16 failed" + exit 1 +} + +# class reference variable +set var_TestClass [createref_TestClass [TestClass tc 20] ] +if {[ [value_TestClass $var_TestClass] cget -num] != 20} { + puts stderr "test 17 failed" + exit 1 +} + diff --git a/trunk/Examples/test-suite/tcl/union_parameter_runme.tcl b/trunk/Examples/test-suite/tcl/union_parameter_runme.tcl new file mode 100644 index 000000000..fb3e092b8 --- /dev/null +++ b/trunk/Examples/test-suite/tcl/union_parameter_runme.tcl @@ -0,0 +1,36 @@ +if [ catch { load ./union_parameter[info sharedlibextension] union_parameter} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +set event [SDL_Event] + +for { set i 0 } { $i < 2 } { incr i } { +# puts -nonewline "Loop $i: " + set evAvailable [SDL_PollEvent $event] + set evType [$event cget -type] +# puts "evType = $evType" + + if { $evType == 1 } { + set specEvent [$event cget -active] +# puts "specEvent = $specEvent" + set type [$specEvent cget -type] + if { $type != $evType } { + error "Type $type should be $evType" + } + set gain [$specEvent cget -gain] + set state [$specEvent cget -state] +# puts "gain=$gain state=$state" + } + if { $evType == 2 } { + set specEvent [$event cget -key] +# puts "specEvent = $specEvent" + set type [$specEvent cget -type] + if { $type != $evType } { + error "Type $type should be $evType" + } + set which [$specEvent cget -which] + set state [$specEvent cget -state] +# puts "which=$which state=$state" + } +# puts "" +} diff --git a/trunk/Examples/test-suite/tcl/unions_runme.tcl b/trunk/Examples/test-suite/tcl/unions_runme.tcl new file mode 100644 index 000000000..8c310950f --- /dev/null +++ b/trunk/Examples/test-suite/tcl/unions_runme.tcl @@ -0,0 +1,63 @@ + +# This is the union runtime testcase. It ensures that values within a +# union embedded within a struct can be set and read correctly. + +if [ catch { load ./unions[info sharedlibextension] unions} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +# Create new instances of SmallStruct and BigStruct for later use +SmallStruct small +small configure -jill 200 + +BigStruct big +big configure -smallstruct [small cget -this] +big configure -jack 300 + +# Use SmallStruct then BigStruct to setup EmbeddedUnionTest. +# Ensure values in EmbeddedUnionTest are set correctly for each. +EmbeddedUnionTest eut + +# First check the SmallStruct in EmbeddedUnionTest +eut configure -number 1 + +#eut.uni.small = small +EmbeddedUnionTest_uni_small_set [EmbeddedUnionTest_uni_get [eut cget -this] ] [small cget -this] + +#Jill1 = eut.uni.small.jill +set Jill1 [SmallStruct_jill_get [EmbeddedUnionTest_uni_small_get [EmbeddedUnionTest_uni_get [eut cget -this] ] ] ] +if {$Jill1 != 200} { + puts stderr "Runtime test1 failed. eut.uni.small.jill=$Jill1" + exit 1 +} + +set Num1 [eut cget -number] +if {$Num1 != 1} { + puts stderr "Runtime test2 failed. eut.number=$Num1" + exit 1 +} + +# Secondly check the BigStruct in EmbeddedUnionTest +eut configure -number 2 +#eut.uni.big = big +EmbeddedUnionTest_uni_big_set [EmbeddedUnionTest_uni_get [eut cget -this] ] [big cget -this] +#Jack1 = eut.uni.big.jack +set Jack1 [BigStruct_jack_get [EmbeddedUnionTest_uni_big_get [EmbeddedUnionTest_uni_get [eut cget -this] ] ] ] +if {$Jack1 != 300} { + puts stderr "Runtime test3 failed. eut.uni.big.jack=$Jack1" + exit 1 +} + +#Jill2 = eut.uni.big.smallstruct.jill +set Jill2 [SmallStruct_jill_get [BigStruct_smallstruct_get [EmbeddedUnionTest_uni_big_get [EmbeddedUnionTest_uni_get [eut cget -this] ] ] ] ] +if {$Jill2 != 200} { + puts stderr "Runtime test4 failed. eut.uni.big.smallstruct.jill=$Jill2" + exit 1 +} + +set Num2 [eut cget -number] +if {$Num2 != 2} { + puts stderr "Runtime test5 failed. eut.number=$Num2" + exit 1 +} + |