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