1#
2# test qsort binding and callback implementation
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
12
13package require Qsort 0.1
14
15testConstraint callback [llength [info commands ::ffidl::callback]]
16
17test ffidl-qsort {ffidl qsort tests} {callback} {
18    set msg {}
19        
20    #
21    # I use these, in error, so often that I should just define them
22    #
23    proc ::ffidl::format {type} { ::ffidl::info format $type }
24    proc ::ffidl::sizeof {type} { ::ffidl::info sizeof $type }
25    
26    #
27    # compare ints given pointers
28    #
29    proc cmp.int {p1 p2} {
30        binary scan [::ffidl::peek $p1 [::ffidl::sizeof int]] [::ffidl::format int] v1
31        binary scan [::ffidl::peek $p2 [::ffidl::sizeof int]] [::ffidl::format int] v2
32        #append msg "cmp.int $p1 $p2 -> $v1 $v2 -> [expr {$v1-$v2}]" "\n"
33        expr {$v1-$v2}
34    }
35    
36    #
37    # define callback
38    #
39    ::ffidl::callback cmp.int {pointer pointer} int
40    
41    #
42    # display a list of ints
43    #
44    proc print.ints {ints} {
45        foreach {i1 i2 i3 i4 i5 i6 i7 i8} $ints {
46            append msg "$i1 $i2 $i3 $i4 $i5 $i6 $i7 $i8" "\n"
47        }
48    }
49    
50    #
51    # construct a binary array of random ints
52    #
53    set n 128
54    for {set i 0} {$i < $n} {incr i} {
55        lappend ints [expr {int(1000*rand())}]
56    }
57    #append msg before "\n"
58    #print.ints $ints
59    set lsorted [lsort -integer $ints]
60    
61    set ints [binary format [::ffidl::format int]* $ints]
62    
63    #
64    # qsort them
65    #
66    qsort ints $n [::ffidl::sizeof int] cmp.int
67    
68    #
69    # convert back to Tcl
70    #
71    binary scan $ints [::ffidl::format int]* ints
72    
73    #
74    # write them out
75    #
76    #append msg after "\n"
77    #print.ints $ints
78    
79    if {[string compare $lsorted $ints] != 0} {
80        append msg "lsorted list:" "\n"
81        print.ints $lsorted
82        append msg "qsorted list:" "\n"
83        print.ints $ints
84    }
85    set msg
86    
87} {}
88
89# cleanup
90::tcltest::cleanupTests
91return
92