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