diff options
Diffstat (limited to 'Examples/test-suite/tcl')
33 files changed, 804 insertions, 34 deletions
diff --git a/Examples/test-suite/tcl/Makefile.in b/Examples/test-suite/tcl/Makefile.in index 322e71914..db8eaa874 100644 --- a/Examples/test-suite/tcl/Makefile.in +++ b/Examples/test-suite/tcl/Makefile.in @@ -6,6 +6,10 @@ LANGUAGE = tcl TCLSH = tclsh SCRIPTSUFFIX = _runme.tcl +HAVE_CXX11 = @HAVE_CXX11@ +HAVE_CXX14 = @HAVE_CXX14@ +HAVE_CXX17 = @HAVE_CXX17@ +HAVE_CXX20 = @HAVE_CXX20@ srcdir = @srcdir@ top_srcdir = @top_srcdir@ top_builddir = @top_builddir@ diff --git a/Examples/test-suite/tcl/argcargvtest_runme.tcl b/Examples/test-suite/tcl/argcargvtest_runme.tcl new file mode 100644 index 000000000..774e86023 --- /dev/null +++ b/Examples/test-suite/tcl/argcargvtest_runme.tcl @@ -0,0 +1,74 @@ +if [ catch { load ./argcargvtest[info sharedlibextension] Argcargvtest} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +set largs {hi hola hello} +if {[mainc $largs] != 3} { + puts stderr "bad main typemap" + exit 1 +} + +set targs {hi hola} +if {[mainv $targs 0] != "hi"} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $targs 1] != "hola"} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $targs 2] != "<<NULL>>"} { + puts stderr "bad main typemap" + exit 1 +} + +set targs " hi hola " +if {[mainv $targs 0] != "hi"} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $targs 1] != "hola"} { + puts stderr "bad main typemap" + exit 1 +} + +if { ! [ catch { mainv("hello", 1) } ] } { + puts stderr "bad main typemap" + exit 1 +} + +initializeApp $largs + +# Check that an empty array works. +set empty_args {} +if {[mainc $empty_args] != 0} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $empty_args 0] != "<<NULL>>"} { + puts stderr "bad main typemap" + exit 1 +} + +# Check that empty strings are handled. +set empty_string {"hello" "" "world"} +if {[mainc $empty_string] != 3} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $empty_string 0] != "hello"} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $empty_string 1] != ""} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $empty_string 2] != "world"} { + puts stderr "bad main typemap" + exit 1 +} +if {[mainv $empty_string 3] != "<<NULL>>"} { + puts stderr "bad main typemap" + exit 1 +} diff --git a/Examples/test-suite/tcl/bools_runme.tcl b/Examples/test-suite/tcl/bools_runme.tcl index 582b8121f..cf446af4a 100644 --- a/Examples/test-suite/tcl/bools_runme.tcl +++ b/Examples/test-suite/tcl/bools_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./bools[info sharedlibextension] bools} err_msg ] { +if [ catch { load ./bools[info sharedlibextension] Bools} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/catches_strings_runme.tcl b/Examples/test-suite/tcl/catches_strings_runme.tcl new file mode 100644 index 000000000..25ef5e715 --- /dev/null +++ b/Examples/test-suite/tcl/catches_strings_runme.tcl @@ -0,0 +1,31 @@ + +if [ catch { load ./catches_strings[info sharedlibextension] Catches_strings} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +set exception_thrown 0 +if [ catch { + StringsThrower_charstring +} e ] { + if {[string first "charstring message" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown an exception" +} + +set exception_thrown 0 +if [ catch { + StringsThrower_stdstring +} e ] { + if {[string first "stdstring message" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown an exception" +} diff --git a/Examples/test-suite/tcl/clientdata_prop_runme.tcl b/Examples/test-suite/tcl/clientdata_prop_runme.tcl index 2ac993fad..e7b89e82a 100644 --- a/Examples/test-suite/tcl/clientdata_prop_runme.tcl +++ b/Examples/test-suite/tcl/clientdata_prop_runme.tcl @@ -1,9 +1,9 @@ -if [ catch { load ./clientdata_prop_b[info sharedlibextension] clientdata_prop_b} err_msg ] { +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 ] { +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 } diff --git a/Examples/test-suite/tcl/cpp11_move_typemaps_runme.tcl b/Examples/test-suite/tcl/cpp11_move_typemaps_runme.tcl new file mode 100644 index 000000000..51624adb6 --- /dev/null +++ b/Examples/test-suite/tcl/cpp11_move_typemaps_runme.tcl @@ -0,0 +1,35 @@ + +if [ catch { load ./cpp11_move_typemaps[info sharedlibextension] Cpp11_move_typemaps} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +Counter_reset_counts +MoveOnly mo 111 +Counter_check_counts 1 0 0 0 0 0 +MoveOnly_take mo +Counter_check_counts 1 0 0 1 0 2 +mo -delete +Counter_check_counts 1 0 0 1 0 2 + +Counter_reset_counts +MovableCopyable mo 111 +Counter_check_counts 1 0 0 0 0 0 +MovableCopyable_take mo +Counter_check_counts 1 0 0 1 0 2 +mo -delete +Counter_check_counts 1 0 0 1 0 2 + +MoveOnly mo 222 +MoveOnly_take mo +set exception_thrown 0 +if [ catch { + MoveOnly_take mo +} e ] { + if {[string first "cannot release ownership as memory is not owned" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown 'Cannot release ownership as memory is not owned' error" +} diff --git a/Examples/test-suite/tcl/cpp11_rvalue_reference_move_runme.tcl b/Examples/test-suite/tcl/cpp11_rvalue_reference_move_runme.tcl new file mode 100644 index 000000000..7bd51f2a2 --- /dev/null +++ b/Examples/test-suite/tcl/cpp11_rvalue_reference_move_runme.tcl @@ -0,0 +1,82 @@ + +if [ catch { load ./cpp11_rvalue_reference_move[info sharedlibextension] Cpp11_rvalue_reference_move} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +# Function containing rvalue reference parameter +Counter_reset_counts +MovableCopyable mo 222 +Counter_check_counts 1 0 0 0 0 0 +MovableCopyable_movein mo +Counter_check_counts 1 0 0 1 0 2 +if {![MovableCopyable_is_nullptr mo]} { + error "is_nullptr failed to throw" +} +mo -delete +Counter_check_counts 1 0 0 1 0 2 + +# Move constructor test +Counter_reset_counts +MovableCopyable mo 222 +Counter_check_counts 1 0 0 0 0 0 +MovableCopyable mo_moved mo +Counter_check_counts 1 0 0 1 0 1 +if {![MovableCopyable_is_nullptr mo]} { + error "is_nullptr failed to throw" +} +mo -delete +Counter_check_counts 1 0 0 1 0 1 +mo_moved -delete +Counter_check_counts 1 0 0 1 0 2 + +# Move assignment operator test +Counter_reset_counts +MovableCopyable mo111 111 +MovableCopyable mo222 222 +Counter_check_counts 2 0 0 0 0 0 +mo111 MoveAssign mo222 +Counter_check_counts 2 0 0 0 1 1 +if {![MovableCopyable_is_nullptr mo222]} { + error "is_nullptr failed to throw" +} +mo222 -delete +Counter_check_counts 2 0 0 0 1 1 +mo111 -delete +Counter_check_counts 2 0 0 0 1 2 + +# null check +Counter_reset_counts +set exception_thrown 0 +if [ catch { + MovableCopyable_movein "NULL" +} e ] { + if {[string first "invalid null reference" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown null error" +} +Counter_check_counts 0 0 0 0 0 0 + +# output +Counter_reset_counts +set mc [MovableCopyable_moveout 1234] +Counter_check_counts 2 0 0 0 1 1 +MovableCopyable_check_numbers_match $mc 1234 + +set exception_thrown 0 +if [ catch { + MovableCopyable_movein $mc +} e ] { + if {[string first "cannot release ownership as memory is not owned" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown 'Cannot release ownership as memory is not owned' error" +} +Counter_check_counts 2 0 0 0 1 1 diff --git a/Examples/test-suite/tcl/cpp11_std_unique_ptr_runme.tcl b/Examples/test-suite/tcl/cpp11_std_unique_ptr_runme.tcl new file mode 100644 index 000000000..afa2145ca --- /dev/null +++ b/Examples/test-suite/tcl/cpp11_std_unique_ptr_runme.tcl @@ -0,0 +1,163 @@ + +if [ catch { load ./cpp11_std_unique_ptr[info sharedlibextension] Cpp11_std_unique_ptr} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +proc checkCount {expected_count} { + set actual_count [Klass_getTotal_count] + if {$actual_count != $expected_count} { + error "Counts incorrect, expected: $expected_count actual: $actual_count" + } +} + +################################# Tcl pointer recycling bug start +# +# ### Possibly related to premature object deletion problem mentioned in newobject1_runme.tcl. ### +# +# While this won't be repeatable on all machines, the following caused the underlying C++ +# pointer value for k1 to be reused for k4. +# +# If the C/C++ memory allocator uses the same pointer value again, then a command name that +# contains a pointer encoding, such as, _b09b1148bd550000_p_Klass (not a variable name) will be +# re-used in SWIG_Tcl_NewInstanceObj. The command should have disappeared from the Tcl side when +# the object was deleted, but there is some sort of bug preventing this from happening in this +# scenario as follows: +# +# Below creates a struct via the call to Tcl_CreateObjCommand in +# SWIG_Tcl_NewInstanceObj (creates a command name with a pointer encoding such as +# _50fb3608ce550000_p_Klass) which also makes a second call to Tcl_CreateObjCommand in +# SWIG_Tcl_ObjectConstructor (creates a command name with the name k1). +Klass k1 "one" +# Line below calls Tcl_DeleteCommandFromToken but is only called for the command created in the +# second call (k1) and not the first call to Tcl_CreateObjCommand. +k1 -delete +set k2 [makeKlassUniquePtr "two"] +set k3 [makeKlassUniquePtr "three"] +$k2 -delete +# If the memory allocator uses the same pointer value, then SWIG_Tcl_NewInstanceObj will find +# the undeleted command _50fb3608ce550000_p_Klass and re-use it. This command should surely +# have been deleted !?? +set k4 [makeKlassUniquePtr "four"] +$k3 -delete +$k4 -delete +checkCount 0 +################################# Tcl pointer recycling bug end + +# Test raw pointer handling involving virtual inheritance +KlassInheritance kini "KlassInheritanceInput" +checkCount 1 +set s [useKlassRawPtr kini] +kini -delete +checkCount 0 + + +# unique_ptr as input +Klass kin "KlassInput" +checkCount 1 +set s [takeKlassUniquePtr kin] +checkCount 0 +if {[kin cget -thisown]} { + error "thisown should be false" +} +if {$s != "KlassInput"} { + error "Incorrect string: $s" +} +if {![is_nullptr kin]} { + error "is_nullptr failed" +} +kin -delete # Should not fail, even though already deleted +checkCount 0 + +Klass kin "KlassInput" +checkCount 1 +set s [takeKlassUniquePtr kin] +checkCount 0 +if {[kin cget -thisown]} { + error "thisown should be false" +} +if {$s != "KlassInput"} { + error "Incorrect string: $s" +} +if {![is_nullptr kin]} { + error "is_nullptr failed" +} +set exception_thrown 0 +if [ catch { set s [takeKlassUniquePtr kin] } e ] { + if {[string first "cannot release ownership as memory is not owned" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "double usage of takeKlassUniquePtr should have been an error" +} +kin -delete # Should not fail, even though already deleted +checkCount 0 + +Klass kin "KlassInput" +set exception_thrown 0 +set notowned [get_not_owned_ptr kin] +if [ catch { + takeKlassUniquePtr notowned +} ] { + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown 'Cannot release ownership as memory is not owned' error" +} +checkCount 1 +kin -delete +checkCount 0 + +KlassInheritance kini "KlassInheritanceInput" +checkCount 1 +set s [takeKlassUniquePtr kini] +checkCount 0 +if {[kini cget -thisown]} { + error "thisown should be false" +} +if {$s != "KlassInheritanceInput"} { + error "Incorrect string: $s" +} +if {![is_nullptr kini]} { + error "is_nullptr failed" +} +kini -delete # Should not fail, even though already deleted +checkCount 0 + +takeKlassUniquePtr "NULL" +takeKlassUniquePtr [make_null] +checkCount 0 + +# overloaded parameters +if {[overloadTest] != 0} { + error "overloadTest failed" +} +if {[overloadTest "NULL"] != 1} { + error "overloadTest failed" +} +if {[overloadTest [Klass k "over"]] != 1} { + error "overloadTest failed" +} +checkCount 0 + + +# unique_ptr as output +set k1 [makeKlassUniquePtr "first"] +set k2 [makeKlassUniquePtr "second"] +checkCount 2 + +$k1 -delete +checkCount 1 + +if {[$k2 getLabel] != "second"} { + error "wrong object label" +} + +$k2 -delete +checkCount 0 + +if {[makeNullUniquePtr] != "NULL"} { + error "null failure" +} diff --git a/Examples/test-suite/tcl/cpp11_strongly_typed_enumerations_runme.tcl b/Examples/test-suite/tcl/cpp11_strongly_typed_enumerations_runme.tcl index 5132101ad..8a36bb90c 100644 --- a/Examples/test-suite/tcl/cpp11_strongly_typed_enumerations_runme.tcl +++ b/Examples/test-suite/tcl/cpp11_strongly_typed_enumerations_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./cpp11_strongly_typed_enumerations[info sharedlibextension] cpp11_strongly_typed_enumerations} err_msg ] { +if [ catch { load ./cpp11_strongly_typed_enumerations[info sharedlibextension] Cpp11_strongly_typed_enumerations} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/cpp17_string_view_runme.tcl b/Examples/test-suite/tcl/cpp17_string_view_runme.tcl new file mode 100644 index 000000000..9be2a4396 --- /dev/null +++ b/Examples/test-suite/tcl/cpp17_string_view_runme.tcl @@ -0,0 +1,46 @@ + +if [ catch { load ./cpp17_string_view[info sharedlibextension] Cpp17_string_view} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +test_value "Fee" + +if {[test_value "Fi"] != "Fi"} { error "bad test_value"} + +test_const_reference "Fo" + +if {[test_const_reference "Fum"] != "Fum"} { error "bad test_const_reference"} + +set stringPtr [test_pointer_out] + +test_pointer $stringPtr + +set stringPtr [test_const_pointer_out] + +test_const_pointer $stringPtr + +set stringPtr [test_reference_out] + +test_reference $stringPtr + +# Global variables +if {$ConstGlobalString != "const global string"} { error "bad ConstGlobalString_get"} + +# Member variables +Structure s +if {[s cget -ConstMemberString] != "const member string"} { error "bad ConstMemberString"} + +if {$Structure_ConstStaticMemberString != "const static member string"} { error "bad ConstStaticMemberString"} + +test_const_reference_returning_void "foo" + +if {[stdstringview_empty] != ""} { error "bad stdstringview_empty test" } +if {[c_empty] != ""} { error "bad c_empty test" } +# FIXME: [c_null] seems to give an empty string currently, but Tcl doesn't have +# a real NULL value and the string "NULL" we used for elsewhere for NULL +# pointers doesn't work well here as it's indistinguishable from the string +# "NULL" being returned. +#if {[c_null] != "NULL"} { error "bad c_null test" } +#if {[get_null [c_null]] != "NULL"} { error "bad get_null c_null test" } +if {[get_null [c_empty]] != "non-null"} { error "bad get_null c_empty test" } +if {[get_null [stdstringview_empty]] != "non-null"} { error "bad get_null stdstringview_empty test" } diff --git a/Examples/test-suite/tcl/disown_runme.tcl b/Examples/test-suite/tcl/disown_runme.tcl index d6647c037..79feefd4c 100644 --- a/Examples/test-suite/tcl/disown_runme.tcl +++ b/Examples/test-suite/tcl/disown_runme.tcl @@ -2,7 +2,7 @@ # 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 ] { +if [ catch { load ./disown[info sharedlibextension] Disown} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/enum_thorough_runme.tcl b/Examples/test-suite/tcl/enum_thorough_runme.tcl index d4cc1995a..731c6e9cb 100644 --- a/Examples/test-suite/tcl/enum_thorough_runme.tcl +++ b/Examples/test-suite/tcl/enum_thorough_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./enum_thorough[info sharedlibextension] enum_thorough} err_msg ] { +if [ catch { load ./enum_thorough[info sharedlibextension] Enum_thorough} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/import_nomodule_runme.tcl b/Examples/test-suite/tcl/import_nomodule_runme.tcl index ead6c3fbe..af778c67e 100644 --- a/Examples/test-suite/tcl/import_nomodule_runme.tcl +++ b/Examples/test-suite/tcl/import_nomodule_runme.tcl @@ -1,4 +1,4 @@ -if [ catch { load ./import_nomodule[info sharedlibextension] import_nomodule} err_msg ] { +if [ catch { load ./import_nomodule[info sharedlibextension] Import_nomodule} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/imports_runme.tcl b/Examples/test-suite/tcl/imports_runme.tcl index 6b2e77bde..cd5629cf6 100644 --- a/Examples/test-suite/tcl/imports_runme.tcl +++ b/Examples/test-suite/tcl/imports_runme.tcl @@ -1,11 +1,11 @@ # This is the imports runtime testcase. proc import {} { - if [ catch { load ./imports_b[info sharedlibextension] imports_b} err_msg ] { + 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 ] { + if [ catch { load ./imports_a[info sharedlibextension] Imports_a} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" exit 1 } @@ -15,8 +15,8 @@ import set x [new_B] A_hello $x -if [ catch { $x nonexistant } ] { +if [ catch { $x nonexistent } ] { } else { - puts stderr "nonexistant method did not throw exception\n" + puts stderr "nonexistent method did not throw exception\n" exit 1 } diff --git a/Examples/test-suite/tcl/integers_runme.tcl b/Examples/test-suite/tcl/integers_runme.tcl new file mode 100644 index 000000000..b06adce9b --- /dev/null +++ b/Examples/test-suite/tcl/integers_runme.tcl @@ -0,0 +1,26 @@ +if [ catch { load ./integers[info sharedlibextension] Integers} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +# 32-bit long max +set val 2147483647 +if {[signed_long_identity $val] != $val} { + puts stderr "Runtime test 1 failed" + exit 1 +} + +set val 3902408827 +if {[unsigned_long_identity $val] != $val} { + puts stderr "Runtime test 2 failed" + exit 1 +} + +if {[signed_long_long_identity $val] != $val} { + puts stderr "Runtime test 3 failed" + exit 1 +} + +if {[unsigned_long_long_identity $val] != $val} { + puts stderr "Runtime test 4 failed" + exit 1 +} diff --git a/Examples/test-suite/tcl/li_carrays_runme.tcl b/Examples/test-suite/tcl/li_carrays_runme.tcl new file mode 100644 index 000000000..5d68fdbe0 --- /dev/null +++ b/Examples/test-suite/tcl/li_carrays_runme.tcl @@ -0,0 +1,71 @@ + +if [ catch { load ./li_carrays[info sharedlibextension] Li_carrays} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +# Testing for %array_functions(int,intArray) +set ary [new_intArray 2] +intArray_setitem $ary 0 0 +intArray_setitem $ary 1 1 +if {[intArray_getitem $ary 0] != 0} { + error "wrong value index 0" +} +if {[intArray_getitem $ary 1] != 1} { + error "wrong value index 1" +} +delete_intArray $ary + +# Testing for %array_class(double, doubleArray) +doubleArray d 10 +doubleArray_setitem d 0 7 +doubleArray_setitem d 5 [expr [doubleArray_getitem d 0] + 3] +if {[expr [doubleArray_getitem d 5] + [doubleArray_getitem d 0]] != 17} { + error "wrong value doubleArray" +} + + +# Tcl Array wrapper based on Tcl.html documentation "Building new kinds of Tcl interfaces (in Tcl)" +proc Array {type size} { + set ptr [new_$type $size] + set code { + set method [lindex $args 0] + set parms [concat $ptr [lrange $args 1 end]] + switch $method { + get {return [eval "${type}_getitem $parms"]} + set {return [eval "${type}_setitem $parms"]} + delete {eval "delete_$type $ptr; rename $ptr {}"} + } + } + # Create a procedure + uplevel "proc $ptr args {set ptr $ptr; set type $type;$code}" + return $ptr +} + +# The memory handling for Tcl is not working properly. +# %newobject (not used here though) is crippled and does not take ownership of the underlying +# pointer - see SWIGTYPE * typemap overrides in tcltypemaps.swg. +# +# As soon as a is set below, it gets deleted by the interpreter, even though $a is used a +# few lines later. The interpreter seems to replace the command object created in +# SWIG_Tcl_NewInstanceObj some sort of generic one. +# The underlying C array is not actually deleted (it leaks) when $a is deleted, so the code +# using $a does actually seem to work. + +set a [Array doubleArray 100] ;# Create a double [100] +for {set i 0} {$i < 100} {incr i 1} { ;# Clear the array + $a set $i 0.0 +} + +$a set 3 3.1455 ;# Set an individual element +set b [$a get 10] ;# Retrieve an element + +set ia [Array intArray 50] ;# Create an int[50] +for {set i 0} {$i < 50} {incr i 1} { ;# Clear it + $ia set $i 0 +} +$ia set 3 7 ;# Set an individual element +set ib [$ia get 10] ;# Get an individual element + +$a delete ;# Destroy a +$ia delete ;# Destroy ia diff --git a/Examples/test-suite/tcl/li_constraints_runme.tcl b/Examples/test-suite/tcl/li_constraints_runme.tcl new file mode 100644 index 000000000..ca7a182e3 --- /dev/null +++ b/Examples/test-suite/tcl/li_constraints_runme.tcl @@ -0,0 +1,51 @@ +if [ catch { load ./li_constraints[info sharedlibextension] Li_constraints} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +proc check_double {except fn f val} { + set actual [ catch { $fn $val } err_msg ] + if { $actual == 0 } { + if { $except != 0 } { + error "function '$f' with $val should perform an exception" + } + } else { + if { $except == 0 } { + error "function '$f' with $val should not perform an exception" + } elseif { [ string equal $err_msg "ValueError Expected a $f value." ] != 1 } { + error "function '$f' with $val should perform a proper exception" + } + } +} + +proc nonnegative {val } { test_nonnegative $val } +check_double 0 nonnegative "non-negative" 10 +check_double 0 nonnegative "non-negative" 0 +check_double 1 nonnegative "non-negative" -10 + +proc nonpositive {val } { test_nonpositive $val } +check_double 1 nonpositive "non-positive" 10 +check_double 0 nonpositive "non-positive" 0 +check_double 0 nonpositive "non-positive" -10 + +proc positive {val } { test_positive $val } +check_double 0 positive "positive" 10 +check_double 1 positive "positive" 0 +check_double 1 positive "positive" -10 + +proc negative {val } { test_negative $val } +check_double 1 negative "negative" 10 +check_double 1 negative "negative" 0 +check_double 0 negative "negative" -10 + +proc nonzero {val } { test_nonzero $val } +check_double 0 nonzero "nonzero" 10 +check_double 1 nonzero "nonzero" 0 +check_double 0 nonzero "nonzero" -10 + +set actual [ catch { test_nonnull NULL } err_msg ] +if { ($actual != 1) || + ([ string equal $err_msg "ValueError Received a NULL pointer." ] != 1) } { + error "Test 'test_nonnull' with null value fail" +} +set nonnull [ get_nonnull ] +test_nonnull $nonnull diff --git a/Examples/test-suite/tcl/li_std_auto_ptr_runme.tcl b/Examples/test-suite/tcl/li_std_auto_ptr_runme.tcl new file mode 100644 index 000000000..8156cb784 --- /dev/null +++ b/Examples/test-suite/tcl/li_std_auto_ptr_runme.tcl @@ -0,0 +1,134 @@ + +if [ catch { load ./li_std_auto_ptr[info sharedlibextension] Li_std_auto_ptr} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + + +proc checkCount {expected_count} { + set actual_count [Klass_getTotal_count] + if {$actual_count != $expected_count} { + error "Counts incorrect, expected: $expected_count actual: $actual_count" + } +} + +################################# Tcl pointer recycling bug start +# Not copied from cpp11_std_unique_ptr_runme.tcl +################################# Tcl pointer recycling bug end + +# Test raw pointer handling involving virtual inheritance +KlassInheritance kini "KlassInheritanceInput" +checkCount 1 +set s [useKlassRawPtr kini] +kini -delete +checkCount 0 + + +# auto_ptr as input +Klass kin "KlassInput" +checkCount 1 +set s [takeKlassAutoPtr kin] +checkCount 0 +if {[kin cget -thisown]} { + error "thisown should be false" +} +if {$s != "KlassInput"} { + error "Incorrect string: $s" +} +if {![is_nullptr kin]} { + error "is_nullptr failed" +} +kin -delete # Should not fail, even though already deleted +checkCount 0 + +Klass kin "KlassInput" +checkCount 1 +set s [takeKlassAutoPtr kin] +checkCount 0 +if {[kin cget -thisown]} { + error "thisown should be false" +} +if {$s != "KlassInput"} { + error "Incorrect string: $s" +} +if {![is_nullptr kin]} { + error "is_nullptr failed" +} +set exception_thrown 0 +if [ catch { set s [takeKlassAutoPtr kin] } e ] { + if {[string first "cannot release ownership as memory is not owned" $e] == -1} { + error "incorrect exception message: $e" + } + set exception_thrown 1 +} +if {!$exception_thrown} { + error "double usage of takeKlassAutoPtr should have been an error" +} +kin -delete # Should not fail, even though already deleted +checkCount 0 + +Klass kin "KlassInput" +set exception_thrown 0 +set notowned [get_not_owned_ptr kin] +if [ catch { + takeKlassAutoPtr notowned +} ] { + set exception_thrown 1 +} +if {!$exception_thrown} { + error "Should have thrown 'Cannot release ownership as memory is not owned' error" +} +checkCount 1 +kin -delete +checkCount 0 + +KlassInheritance kini "KlassInheritanceInput" +checkCount 1 +set s [takeKlassAutoPtr kini] +checkCount 0 +if {[kini cget -thisown]} { + error "thisown should be false" +} +if {$s != "KlassInheritanceInput"} { + error "Incorrect string: $s" +} +if {![is_nullptr kini]} { + error "is_nullptr failed" +} +kini -delete # Should not fail, even though already deleted +checkCount 0 + +takeKlassAutoPtr "NULL" +takeKlassAutoPtr [make_null] +checkCount 0 + +# overloaded parameters +if {[overloadTest] != 0} { + error "overloadTest failed" +} +if {[overloadTest "NULL"] != 1} { + error "overloadTest failed" +} +if {[overloadTest [Klass k "over"]] != 1} { + error "overloadTest failed" +} +checkCount 0 + + +# auto_ptr as output +set k1 [makeKlassAutoPtr "first"] +set k2 [makeKlassAutoPtr "second"] +checkCount 2 + +$k1 -delete +checkCount 1 + +if {[$k2 getLabel] != "second"} { + error "wrong object label" +} + +$k2 -delete +checkCount 0 + +if {[makeNullAutoPtr] != "NULL"} { + error "null failure" +} diff --git a/Examples/test-suite/tcl/li_std_string_runme.tcl b/Examples/test-suite/tcl/li_std_string_runme.tcl index 333c1f1be..8f4cf4d99 100644 --- a/Examples/test-suite/tcl/li_std_string_runme.tcl +++ b/Examples/test-suite/tcl/li_std_string_runme.tcl @@ -1,15 +1,38 @@ -if [ catch { load ./li_std_string[info sharedlibextension] li_std_string} err_msg ] { +if [ catch { load ./li_std_string[info sharedlibextension] Li_std_string} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } +test_value "Fee" -Structure s +if {[test_value "Fi"] != "Fi"} { error "bad test_value"} + +test_const_reference "Fo" + +if {[test_const_reference "Fum"] != "Fum"} { error "bad test_const_reference"} + +set stringPtr [test_pointer_out] + +test_pointer $stringPtr + +set stringPtr [test_const_pointer_out] + +test_const_pointer $stringPtr + +set stringPtr [test_reference_out] + +test_reference $stringPtr + +# Global variables +if {$ConstGlobalString != "const global string"} { error "bad ConstGlobalString_get"} + +# Member variables +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 {[s cget -ConstMemberString] != "const member string"} { error "bad ConstMemberString"} if {"$GlobalString2" != "global string 2"} { error "bad string map"} if {"$Structure_StaticMemberString2" != "static member string 2"} { error "bad string map"} @@ -19,3 +42,18 @@ if {"$GlobalString2" != "hello"} { error "bad string map"} set Structure_StaticMemberString2 "hello" if {"$Structure_StaticMemberString2" != "hello"} { error "bad string map"} + +if {$Structure_ConstStaticMemberString != "const static member string"} { error "bad ConstStaticMemberString"} + +test_const_reference_returning_void "foo" + +if {[stdstring_empty] != ""} { error "bad stdstring_empty test" } +if {[c_empty] != ""} { error "bad c_empty test" } +# FIXME: [c_null] seems to give an empty string currently, but Tcl doesn't have +# a real NULL value and the string "NULL" we used for elsewhere for NULL +# pointers doesn't work well here as it's indistinguishable from the string +# "NULL" being returned. +#if {[c_null] != "NULL"} { error "bad c_null test" } +#if {[get_null [c_null]] != "NULL"} { error "bad get_null c_null test" } +if {[get_null [c_empty]] != "non-null"} { error "bad get_null c_empty test" } +if {[get_null [stdstring_empty]] != "non-null"} { error "bad get_null stdstring_empty test" } diff --git a/Examples/test-suite/tcl/li_std_vector_runme.tcl b/Examples/test-suite/tcl/li_std_vector_runme.tcl new file mode 100644 index 000000000..24aa9aa42 --- /dev/null +++ b/Examples/test-suite/tcl/li_std_vector_runme.tcl @@ -0,0 +1,15 @@ + +if [ catch { load ./li_std_vector[info sharedlibextension] Li_std_vector} err_msg ] { + puts stderr "Could not load shared object:\n$err_msg" +} + +# Regression test for bug fixed in SWIG 4.1.0. +if {[sum []] != 0} { error "bad vector sum" } + +IntPtrVector v 6 +if {[v empty] != 0} { error "bad std::vector::empty()" } +if {[v size] != 6} { error "bad std::vector::size()" } +# Test that calling get succeeds +v get 0 +v pop +if {[v size] != 5} { error "bad std::vector::size()" } diff --git a/Examples/test-suite/tcl/member_pointer_runme.tcl b/Examples/test-suite/tcl/member_pointer_runme.tcl index e4d099163..7ba5321b5 100644 --- a/Examples/test-suite/tcl/member_pointer_runme.tcl +++ b/Examples/test-suite/tcl/member_pointer_runme.tcl @@ -1,6 +1,6 @@ # Example using pointers to member functions -if [ catch { load ./member_pointer[info sharedlibextension] member_pointer} err_msg ] { +if [ catch { load ./member_pointer[info sharedlibextension] Member_pointer} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/newobject1_runme.tcl b/Examples/test-suite/tcl/newobject1_runme.tcl index da6ff6679..707cc7ec5 100644 --- a/Examples/test-suite/tcl/newobject1_runme.tcl +++ b/Examples/test-suite/tcl/newobject1_runme.tcl @@ -1,4 +1,4 @@ -if [ catch { load ./newobject1[info sharedlibextension] newobject1} err_msg ] { +if [ catch { load ./newobject1[info sharedlibextension] Newobject1} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/newobject2_runme.tcl b/Examples/test-suite/tcl/newobject2_runme.tcl index 18d23af33..330a0c4e4 100644 --- a/Examples/test-suite/tcl/newobject2_runme.tcl +++ b/Examples/test-suite/tcl/newobject2_runme.tcl @@ -1,4 +1,4 @@ -if [ catch { load ./newobject2[info sharedlibextension] newobject2} err_msg ] { +if [ catch { load ./newobject2[info sharedlibextension] Newobject2} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/null_pointer_runme.tcl b/Examples/test-suite/tcl/null_pointer_runme.tcl index 7ed87c153..8c77a9ed0 100644 --- a/Examples/test-suite/tcl/null_pointer_runme.tcl +++ b/Examples/test-suite/tcl/null_pointer_runme.tcl @@ -1,4 +1,4 @@ -if [ catch { load ./null_pointer[info sharedlibextension] null_pointer} err_msg ] { +if [ catch { load ./null_pointer[info sharedlibextension] Null_pointer} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/overload_copy_runme.tcl b/Examples/test-suite/tcl/overload_copy_runme.tcl index 46d7058d5..973ae141a 100644 --- a/Examples/test-suite/tcl/overload_copy_runme.tcl +++ b/Examples/test-suite/tcl/overload_copy_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./overload_copy[info sharedlibextension] overload_copy} err_msg ] { +if [ catch { load ./overload_copy[info sharedlibextension] Overload_copy} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/overload_null_runme.tcl b/Examples/test-suite/tcl/overload_null_runme.tcl index 3716612ab..314036ed4 100644 --- a/Examples/test-suite/tcl/overload_null_runme.tcl +++ b/Examples/test-suite/tcl/overload_null_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./overload_null[info sharedlibextension] overload_null} err_msg ] { +if [ catch { load ./overload_null[info sharedlibextension] Overload_null} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } @@ -40,13 +40,13 @@ check "testX" 14 [$o byval1cpr "NULL"] check "testX" 15 [$o byval2cpr "NULL"] check "testX" 16 [$o byval2cpr $x] -# forward class declaration -check "testX" 17 [$o byval1forwardptr $x] -check "testX" 18 [$o byval1forwardptr "NULL"] +# fwd class declaration +check "testX" 17 [$o byval1fwdptr $x] +check "testX" 18 [$o byval1fwdptr "NULL"] -check "testX" 19 [$o byval2forwardptr "NULL"] -check "testX" 20 [$o byval2forwardptr $x] +check "testX" 19 [$o byval2fwdptr "NULL"] +check "testX" 20 [$o byval2fwdptr $x] -check "testX" 21 [$o byval1forwardref $x] +check "testX" 21 [$o byval1fwdref $x] -check "testX" 22 [$o byval2forwardref $x] +check "testX" 22 [$o byval2fwdref $x] diff --git a/Examples/test-suite/tcl/overload_simple_runme.tcl b/Examples/test-suite/tcl/overload_simple_runme.tcl index 6b65ccc90..add4248f8 100644 --- a/Examples/test-suite/tcl/overload_simple_runme.tcl +++ b/Examples/test-suite/tcl/overload_simple_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./overload_simple[info sharedlibextension] overload_simple} err_msg ] { +if [ catch { load ./overload_simple[info sharedlibextension] Overload_simple} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/primitive_ref_runme.tcl b/Examples/test-suite/tcl/primitive_ref_runme.tcl index ab4e444d2..53faee57d 100644 --- a/Examples/test-suite/tcl/primitive_ref_runme.tcl +++ b/Examples/test-suite/tcl/primitive_ref_runme.tcl @@ -1,7 +1,7 @@ # 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 ] { +if [ catch { load ./primitive_ref[info sharedlibextension] Primitive_ref} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/primitive_types_runme.tcl b/Examples/test-suite/tcl/primitive_types_runme.tcl index fa4c46ba5..444062f2c 100644 --- a/Examples/test-suite/tcl/primitive_types_runme.tcl +++ b/Examples/test-suite/tcl/primitive_types_runme.tcl @@ -1,5 +1,5 @@ -if [ catch { load ./primitive_types[info sharedlibextension] primitive_types} err_msg ] { +if [ catch { load ./primitive_types[info sharedlibextension] Primitive_types} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/profiletest_runme.tcl b/Examples/test-suite/tcl/profiletest_runme.tcl index 087eea463..22d91ec58 100644 --- a/Examples/test-suite/tcl/profiletest_runme.tcl +++ b/Examples/test-suite/tcl/profiletest_runme.tcl @@ -1,4 +1,4 @@ -catch { load ./profiletest[info sharedlibextension] profiletest} +catch { load ./profiletest[info sharedlibextension] Profiletest} set a [new_A] set b [new_B] diff --git a/Examples/test-suite/tcl/reference_global_vars_runme.tcl b/Examples/test-suite/tcl/reference_global_vars_runme.tcl index bfd31a949..b471e3758 100644 --- a/Examples/test-suite/tcl/reference_global_vars_runme.tcl +++ b/Examples/test-suite/tcl/reference_global_vars_runme.tcl @@ -1,4 +1,4 @@ -if [ catch { load ./reference_global_vars[info sharedlibextension] reference_global_vars} err_msg ] { +if [ catch { load ./reference_global_vars[info sharedlibextension] Reference_global_vars} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/union_parameter_runme.tcl b/Examples/test-suite/tcl/union_parameter_runme.tcl index fb3e092b8..d6a324e63 100644 --- a/Examples/test-suite/tcl/union_parameter_runme.tcl +++ b/Examples/test-suite/tcl/union_parameter_runme.tcl @@ -1,4 +1,4 @@ -if [ catch { load ./union_parameter[info sharedlibextension] union_parameter} err_msg ] { +if [ catch { load ./union_parameter[info sharedlibextension] Union_parameter} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } diff --git a/Examples/test-suite/tcl/unions_runme.tcl b/Examples/test-suite/tcl/unions_runme.tcl index 8c310950f..2723d383f 100644 --- a/Examples/test-suite/tcl/unions_runme.tcl +++ b/Examples/test-suite/tcl/unions_runme.tcl @@ -2,7 +2,7 @@ # 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 ] { +if [ catch { load ./unions[info sharedlibextension] Unions} err_msg ] { puts stderr "Could not load shared object:\n$err_msg" } |