1# 2# ffidl callback testing 3# 4 5if {[lsearch [namespace children] ::tcltest] == -1} { 6 package require tcltest 7 namespace import -force ::tcltest::* 8} 9 10package require Ffidl 11package require Ffidlrt 12set lib [::ffidl::find-lib ffidl_test] 13 14testConstraint callback [llength [info commands ::ffidl::callback]] 15 16test ffidl-callbacks {ffidl callback tests} {callback} { 17 18 ::ffidl::callout fchar {pointer-proc char char} char [::ffidl::symbol $lib ffidl_fchar] 19 ::ffidl::callout fshort {pointer-proc short short} short [::ffidl::symbol $lib ffidl_fshort] 20 ::ffidl::callout fint {pointer-proc int int} int [::ffidl::symbol $lib ffidl_fint] 21 ::ffidl::callout flong {pointer-proc long long} long [::ffidl::symbol $lib ffidl_flong] 22 ::ffidl::callout flonglong {pointer-proc {long long} {long long}} {long long} [::ffidl::symbol $lib ffidl_flonglong] 23 ::ffidl::callout ffloat {pointer-proc float float} float [::ffidl::symbol $lib ffidl_ffloat] 24 ::ffidl::callout fdouble {pointer-proc double double} double [::ffidl::symbol $lib ffidl_fdouble] 25 26 set nsuccesses 0 27 set ntests 0 28 29 foreach {func type} { 30 fchar char 31 fshort short 32 fint int 33 flong long 34 flonglong {long long} 35 ffloat float 36 fdouble double 37 } { 38 ::ffidl::callback $func.$type [list $type $type] $type 39 proc $func.$type {a b} { expr {$a+$b} } 40 switch $type { 41 char { 42 set a [expr {int(64*rand())}] 43 set b [expr {int(64*rand())}] 44 } 45 short { 46 set a [expr {int(16384*rand())}] 47 set b [expr {int(16384*rand())}] 48 } 49 int - 50 long { 51 set a [expr {int(1000000*rand())}] 52 set b [expr {int(1000000*rand())}] 53 } 54 {long long} { 55 set a [expr {int(1000000*rand())}] 56 set b [expr {int(1000000*rand())}] 57 } 58 float { 59 set a [expr {int(1000000*rand())}] 60 set b [expr {int(1000000*rand())}] 61 } 62 double { 63 set a [expr {rand()}] 64 set b [expr {rand()}] 65 } 66 } 67 if {[$func $func.$type $a $b] != [expr {$a+$b}]} { 68 append msg "$func $a $b -> [$func $func.$type $a $b] ?= [expr {$a+$b}]" "\n" 69 } else { 70 incr nsuccesses 71 } 72 incr ntests 73 } 74 75 ::ffidl::callout isort {pointer-var int pointer-proc} void [::ffidl::symbol $lib ffidl_isort] 76 77 proc icompar {p1 p2} { 78 binary scan [::ffidl::peek $p1 [::ffidl::info sizeof int]] [::ffidl::info format int] v1 79 binary scan [::ffidl::peek $p2 [::ffidl::info sizeof int]] [::ffidl::info format int] v2 80 #append msg "icompar $p1 $p2 -> $v1 $v2 -> [expr {$v1-$v2}]" "\n" 81 expr {$v1-$v2} 82 } 83 ::ffidl::callback icompar {pointer pointer} int 84 85 # 86 # display a list of ints 87 # 88 proc print {ints} { 89 foreach {i1 i2 i3 i4 i5 i6 i7 i8} $ints { 90 append msg "$i1 $i2 $i3 $i4 $i5 $i6 $i7 $i8" "\n" 91 } 92 } 93 94 # 95 # construct a binary array of random ints 96 # 97 set n 8 98 for {set i 0} {$i < $n} {incr i} { 99 lappend ints [expr {int(1000*rand())}] 100 } 101 #append msg before "\n" 102 #print $ints 103 set lsorted [lsort -integer $ints] 104 set ints [binary format [::ffidl::info format int]* $ints] 105 106 # 107 # isort them 108 # 109 isort ints $n icompar 110 111 # 112 # convert back to Tcl 113 # 114 binary scan $ints [::ffidl::info format int]* ints 115 116 #append msg after "\n" 117 #print $ints 118 119 if {[string compare $ints $lsorted] != 0} { 120 append msg "lsorted list:" "\n" 121 print $lsorted 122 append msg "isorted list:" "\n" 123 print $ints 124 } else { 125 incr nsuccesses 126 } 127 incr ntests 128 129 append msg "[expr {$ntests-$nsuccesses}] failures in $ntests tests" 130 set msg 131 132} {0 failures in 8 tests} 133 134# cleanup 135::tcltest::cleanupTests 136return 137