# demo.tcl --
#
# Code that demonstrates the Tcl-to-LLVM compilation capabilities of
# tclquadcode. Most of this file is demonstration procedures that we can
# compile; the rest is the driver code (though that is mostly factored
# out into demosupport.tcl).
#
# Copyright (c) 2014-2017 by Kevin B. Kenny
# Copyright (c) 2014-2017 by Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
#############################################################################
#
# Test code definitions. These are all procedures; that's all we can currently
# compile.
proc cos {x {n 16}} {
# set x [expr {double($x)}]
# set n [expr {int($n)}]
set j 0
set s 1.0
set t 1.0
set i 0
while {[incr i] < $n} {
set t [expr {-$t*$x*$x / [incr j] / [incr j]}]
set s [expr {$s + $t}]
}
return $s
}
proc coscaller1 {x} {
cos [expr {double($x)}]
}
proc coscaller2 {} {
for {set i -100} {$i <= 100} {incr i} {
set x [expr {0.00314159 * $i}]
cos $x
}
}
proc fib {n} {
set n [expr {int($n)}]
if {$n < 1} {
return 0
}
set a 0
set b 1
for {set i 1} {$i < $n} {incr i} {
set c [expr {$a + $b}]
set a $b
set b $c
}
return $b
}
proc inttest {x} {
set x [expr {int($x)}]
incr x $x
expr {($x / 3)**7 * 2 + $x}
}
proc shift {x y} {
set y [expr {int($y)}]
expr {int($x) >> $y}
}
proc tantest {x} {
return [expr {tan(double($x))**3}]
}
proc polartest {u v} {
set th [expr {atan2($v,$u)}]
set r [expr {hypot($v,$u)}]
set u2 [expr {$r * cos($th)}]
set v2 [expr {$r * sin($th)}]
return [expr {hypot($v2-$v, $u2-$u)}]
}
# This is a cut-down version of the version in Tcllib's math package
namespace eval math {}
proc ::math::ln_Gamma { x } {
# Handle the common case of a real argument that's within the
# permissible range.
if { [string is double -strict $x]
&& ( $x > 0 )
&& ( $x <= 2.5563481638716906e+305 )
} {
set x [expr { $x - 1.0 }]
set tmp [expr { $x + 5.5 }]
set tmp [ expr { ( $x + 0.5 ) * log( $tmp ) - $tmp }]
set ser 1.0
foreach cof {
76.18009173 -86.50532033 24.01409822
-1.231739516 .00120858003 -5.36382e-6
} {
set x [expr { $x + 1.0 }]
set ser [expr { $ser + $cof / $x }]
}
return [expr { $tmp + log( 2.50662827465 * $ser ) }]
}
# Handle the error cases.
if { ![string is double -strict $x] } {
return -code error -errorcode {TCL VALUE NUMBER} \
"expected a floating point number but got \"$x\""
}
if { $x <= 0.0 } {
return -code error \
-errorcode {ARITH DOMAIN {non-positive number}} \
"argument to ::math::ln_Gamma must be positive"
}
return -code error \
-errorcode [list ARITH OVERFLOW \
"floating-point value too large to represent"] \
"floating-point value too large to represent"
}
proc powmul1 {n r} {
set n [expr {int($n)}]
set r [expr {int($r)}]
for {set i 0} {$i < $n} {incr i} {
set r [expr {$r * $n}]
}
return $r
}
proc powmul2 {n r} {
for {set i 0} {$i < $n} {incr i} {
set r [expr {$r * $n}]
}
return $r
}
proc strtest {x y} {
set y [expr {int($y)}]
for {set i [expr {int($x)}]; set j 0} {$i <= $y} {incr i} {
incr j [string length $i]
}
return $j
}
proc passthrough {{a "example"}} {
return $a
}
proc streqtest {a b} {
if {$a ne $b} {
return "is not equal"
} else {
return "is equal"
}
}
proc strconcattest {a b {n 8}} {
set s $a.$b
for {set i 0} {$i < 10} {incr i} {
set s $a.$b.$i
if {$i > int($n)} {
return $s
}
}
return $s
}
proc comparetest {a b} {
for {set x 1; set y 1.0} {$x < int($a) && $y < double($b)} {incr x} {
set y [expr {$y * 1.3}]
}
return $x~$y
}
proc appendtest {n} {
set s ""
set t ""
for {set i 1} {$i <= int($n)} {incr i} {
append s $t
append s $i
set t ","
}
return $s
}
proc appendtest2 {n} {
set s ""
for {set i 1} {$i <= int($n)} {incr i} {
if {$i > 1} {
append s ,
}
append s $i
}
return $s
}
proc appendtest3 {n} {
set s ""
for {set i 1; set t ""} {$i <= int($n)} {incr i; set t ","} {
append s $t $i
}
return $s
}
proc rev {str} {
set accum {}
for {set i [string length $str]} {[incr i -1] >= 0} {} {
append accum [string index $str $i]
}
return $accum
}
proc idx {str} {
return [string index $str 3]
}
proc ranged {str} {
set accum {}
for {set i 0; set j [string length $str]} {$i<[incr j -1]} {incr i} {
append accum [string range $str $i $j] ,
}
return $accum
}
proc substrtest {from to} {
set s abcdefghijklmnopqrstuvwxyz
set from [string first $from $s]
set to [string last $to $s]
return [string cat [string range $s 0 [expr {$from-1}]] > \
[string range $s $from $to] < \
[string range $s [expr {$to+1}] end]]
}
proc replacing {from to} {
set s abcdefghijklmnopqrstuvwxyz
set from [string first $from $s]
set to [string last $to $s]
return [string replace $s $from $to \
[string cat > [string range $s $from $to] <]]
}
proc replacing2 {str} {
string cat > [string map {cde CDEF} $str] | [string map {def XYZ} $str] \
| [string map {ghi ""} $str] <
}
proc replacing3 {str} {
set x 7
set x end-$x
set y end-3
string replace $str $x $y [string cat | [string range $str $x $y] |]
}
proc substrtest2 {from to} {
set s abcdefghijklmnopqrstuvwxyz
string range $s [string first $from $s] [string last $to $s]
}
proc matchtest {str} {
string match *abc* $str
}
proc cmptest {str} {
string compare *abc* $str
}
proc cmptest2 {a b} {
list [expr {$a == $b}] [expr {$a != $b}] \
[expr {$a > $b}] [expr {$a >= $b}] \
[expr {$a < $b}] [expr {$a <= $b}] \
$a $b
}
proc trimtest {str} {
string cat [string trimleft $str ABC] | [string trim $str ABC] | \
[string trimright $str ABC]
}
proc casetest {str} {
string cat [string toupper $str] | [string tolower $str] | [string totitle $str]
}
proc strclasstest {str} {
string is xdigit $str
}
proc switchfail {str} {
set s D
switch -regexp -- $str {
abc {
set s A
}
def {
set s B
}
.*(?:y).** {
set s C
}
}
return $s
}
proc uplustest {x y} {
return [expr {+ "$x$y"}]
}
proc wideretest {x} {
lindex $x 1
return "a constant"
}
proc substtest {str} {
subst {>>$str|[
string cat [regexp .+a.+ $str] .
]|$str|[
string cat [regexp .+q.+ $str] .
]|$str<<}
}
proc substtest2 {str} {
set i 0
subst {>>$str|[incr i]|$str|[incr i]|$str<<}
}
proc listtest {x y} {
list 1 $x abc $y 0.12
}
proc listjoin1 {list} {
set result ""
set sep ""
for {set i 0} {$i < [llength $list]} {incr i} {
append result $sep [lindex $list $i]
set sep ","
}
return $result
}
proc listjoin2 {list} {
set result ""
set sep ""
foreach item $list {
append result $sep $item
set sep ","
}
return $result
}
proc listjoin3 {list} {
return [join $list ","]
}
proc magicreturn {x} {
set y [return -level 0 [expr {int($x) + int($x)}]]
set l 0
set z [return -level $l [expr {$y + $y}]]
return [expr {$z + $z}]
}
proc returntest {x y} {
set c [catch {
return -options {a b} -foo $y $x
} a b]
return [list a= $a c= $c b= $b]
}
proc errortest1 {x} {
set b [catch { error $x$x$x } a]
return "a=$a b=$b"
}
proc errortest2 {x} {
error $x$x$x
}
proc errortest3 {x} {
set msg ok
try {
if {[string length $x] == 3} {
error $x$x$x
}
} on error msg {
}
return $msg
}
proc errortest4 {x} {
set msg ok
try {
if {[string length $x] == 3} {
error $x$x$x
}
} on error msg {
error "error occurred: $msg"
}
return $msg
}
proc errortest4a {x} {
list [catch {errortest4 $x} msg] $msg
}
proc errortest5 {x} {
catch {throw {FOO BAR} $x} a b
list $a [dict get $b -errorcode]
}
proc errortest6 {x} {
set x [expr {int($x)}]
set msg ok
try {
if {$x == 1} {
throw {FOO BAR} "x is $x - 1"
} elseif {$x == 2} {
throw {FOO BOO} "x ix $x - 2"
} else {
set msg "x is $x - 3"
}
} trap {FOO BAR} m {
set msg '$m'
} on error {m o} {
set msg "''$m''"
}
return $msg
}
proc errortest2-caller {str} {
set code [catch {
errortest2 $str
} msg opt]
dict unset opt -errorstack
dict unset opt -errorinfo
list $code $msg $opt
}
proc dictest {d} {
if {[dict exists $d foo]} {
dict set d foofoo [dict get $d foo]
return [dict unset d foo]
}
return "nothing at_all"
}
proc dictest2 {d} {
dict append d abc 123x
dict append d abc 456y
dict lappend d abc def
dict lappend d abc ghi
dict incr d def
dict incr d def 3
return $d
}
proc dictest3 {d} {
dict update d a b {
set b $b.$b
}
return $d
}
proc dictest4 {a b c d} {
set x [dict create $a 1 $b 2 $c 3 $d 4]
set y [dict merge $x]
list $x $y
}
proc dictest5 {} {
dict set d a b
return $d
}
proc dictest6 {} {
for {set i 0} {$i < 10} {incr i} {
dict set d $i x
}
return $d
}
proc lrangetest {l} {
return [lrange $l 0 3],[lrange $l end-1 end]
}
proc lsetest {l {ix { 2 }}} {
for {set i 0} {$i < [llength $l]} {incr i} {
lset l $i >[lindex $l $i]<
}
lset l $ix abc
lset l 1 1 def
return $l
}
proc lappendtest {l} {
lappend l a
lappend l b c
return $l
}
proc jumptable {a} {
switch $a {
a {return aaa}
b {return bbb}
c {return ccc}
}
return ddd
}
proc rangetest {from to} {
set result {}
set i [expr {int($from)}]
set j [expr {int($to)}]
for {} {$i <= $j} {incr i} {
lappend result $i
}
return $result
}
proc numberitems {list} {
set result {}
set i 0
foreach item $list {
lappend result [incr i]:$item
}
return $result
}
proc numberitems2 {list} {
set result {}
set i 0
foreach sublist $list {
foreach item $sublist {
lappend result [incr i]:$item
}
}
return $result
}
proc numberitems3 {list} {
set result {}
set i 0
foreach {item1 item2} $list {
lappend result [incr i]:$item1:$item2
}
return $result
}
proc doubleitems {list} {
lmap x $list {string cat $x $x}
}
proc containment {list} {
expr {"a" in $list && "b" ni $list}
}
proc dictfor {dictionary} {
set result {}
dict for {k v} $dictionary {
lappend result "d($k)=$v"
}
return $result
}
proc concatenater {x} {
set x [expr {int($x)}]
concat [expr {$x - 1}] $x [expr {$x + 1.5}] "ok"
}
proc booltest {val} {
set res {}
if {[string is boolean -strict $val]} {
lappend res ok
}
lappend res [string is boolean $val]
lappend res [string is true -strict $val] [string is true $val]
lappend res [string is false -strict $val] [string is false $val]
return $res
}
proc stristest {x} {
return [
string is int -strict $x
],[
string is double -strict $x
],[
string is int $x
],[
string is double $x
]
}
proc wordcounter1 {words} {
foreach word $words {
incr count($word)
set done($word) 0
}
lmap word $words {
if {$done($word)} continue
set done($word) 1
list $word $count($word)
}
}
proc wordcounter2 {words} {
array set count {}
array set done {}
foreach word $words {
incr count($word)
set done($word) 0
}
lmap word $words {
if {$done($word)} continue
set done($word) 1
list $word $count($word)
}
}
proc wordcounter3 {words} {
set count(example) 49
array set count {}
array set done {example 1}
foreach word $words {
incr count($word)
incr done($word) 0
}
lmap word $words {
if {$done($word)} continue
set done($word) 1
list $word $count($word)
}
}
proc calltest {from to joiner} {
set to [expr {int($to)}]
set l {}
for {set i [expr {int($from)}]} {$i <= $to} {incr i} {
lappend l $i
}
return [join $l $joiner]
}
proc calltest2 {from to joiner} {
set to [expr {int($to)}]
set l {}
for {set i [expr {int($from)}]} {$i <= $to} {incr i} {
lappend l $i
}
return [join $l $joiner "trigger an error"]
}
proc calltest3 {from to} {
set result {}
set d {a 5 b 7 c 8}
for {set i [expr {int($from)}]} {$i < int($to)} {incr i} {
set v [lindex [dict values $d] $i]
lappend result $v [expr {$v ** $i}]
}
return $result
}
proc nextest1 {x} { # throwIfNotExists, unoptimized
if {$x} {
set y 1
}
list [catch {set y} result] $result
}
proc nextest2 {x} { # throwIfNotExists, extractExists, unset, optimized
# both ways
if {$x} {
set y 1
}
list [catch {
if {[info exists y]} {
return -level 0 [list 1 $y]
} else {
return -level 0 [list 0 $y]
}
} result] $result
}
proc nextest3 {x} { # initIfNotExists, optimized both ways
if {$x} {
set y {a b}
}
if {[info exists y]} {
return [dict set y a b]
} else {
return [dict set y c d]
}
}
proc nextest4 {} {
if {[info exists x]} {
return "BAD"
} else {
return "GOOD"
}
}
proc xsum {a args} {
foreach b $args {
set a [expr {$a + $b}]
}
return $a
}
proc xsum2 {} {
list \
[catch {xsum 1} r] $r \
[catch {xsum 2} r] $r \
[catch {xsum 1.0} r] $r \
[catch {xsum 1.0 2 3 4} r] $r \
[catch {xsum 1 2 3 4.0} r] $r \
[catch {xsum 2 1 3 4.0} r] $r \
[catch {xsum 1 2 3 4} r] $r \
[catch {xsum 2 1 3 4} r] $r \
[catch {xsum 1 fish head} r] $r
# [catch {xsum} r] $r I'm not doing "wrong # args" yet
}
namespace eval mrtest {
namespace export calc integer plus minus times quotient fibo rfib
proc calc {x} {
switch -exact -- [lindex $x 0] {
"i" {
set result [integer [lindex $x 1]]
}
"+" {
set result [plus [lindex $x 1] [lindex $x 2]]
}
"-" {
set result [minus [lindex $x 1] [lindex $x 2]]
}
"*" {
set result [times [lindex $x 1] [lindex $x 2]]
}
"/" {
set result [quotient [lindex $x 1] [lindex $x 2]]
}
"f" {
set result [fibo [lindex $x 1]]
}
}
return $result
}
proc integer {x} {
expr {int($x)}
}
proc plus {x y} {
expr {[calc $x] + [calc $y]}
}
proc minus {x y} {
expr {[calc $x] - [calc $y]}
}
proc times {x y} {
expr {[calc $x] * [calc $y]}
}
proc quotient {x y} {
expr {[calc $x] / [calc $y]}
}
proc fibo {x} {
return [rfib [calc $x]]
}
proc rfib {x} {
if {$x <= 1} {
return 1
} else {
return [expr {[rfib [expr {$x - 1}]] + [rfib [expr {$x - 2}]]}]
}
}
}
proc bctest {x {r 0}} {
if {$r} {
set t f
set f t
} else {
set t t
set f f
}
expr {($x == $t || $x == $f) && ($t || $f)}
}
proc asmtest {} {
::tcl::unsupported::assemble {
beginCatch @badLabel
push error
push testing
invokeStk 2
endCatch
pop
push 0
jump @okLabel
label @badLabel
endCatch
push 1; # should be pushReturnCode
label @okLabel
pop
}
return ok
}
namespace eval nstest {
interp alias {} [namespace current]::pts {} ::puts
proc nstest0 {} {
namespace which ::puts
}
proc nstest1 {} {
namespace which ::nstest::pts
}
proc nstest2 {} {
namespace which pts
}
proc nstest3 {} {
namespace origin [namespace which ::puts]
}
proc nstest4 {} {
namespace origin ::nstest::pts
}
proc nstest5 {} {
namespace origin pts
}
proc nstest6 {} {
namespace origin puts
}
proc nstest7 {} {
namespace origin fish-head
}
}
namespace eval bug-0616bcf08e {
proc mulsum {x y z} {
expr {double($x) * double($y) + double($z)}
}
proc msrange {from to} {
set total [expr {double(0.0)}]
for {set i [expr {int($from)}]} {$i<int($to)} {incr i} {
set total [mulsum $total $i $i]
}
return $total
}
proc mulsum2 {x y z} {
expr {$x * $y + $z}
}
proc msrange2 {from to} {
set total 0.0
set from [expr {$from + 0}]
set to [expr {$to + 0}]
for {set i $from} {$i<$to} {incr i} {
set total [mulsum $total $i $i]
}
return $total
}
}
proc lcmRange {to} {
set to [expr {int($to)}]
set primes {}
set plist {}
for {set i 2} {$i <= $to} {incr i} {
set j $i
set thisp {}
foreach p $plist {
while {$j % $p == 0} {
set j [expr {$j / $p}]
dict incr thisp $p
}
}
if {$j > 1} {
lappend plist $j
dict incr primes $j
}
dict for {p c} $thisp {
if {[dict get $primes $p] < $c} {
dict set primes $p $c
}
}
}
set lcm 1
dict for {p c} $primes {
set lcm [expr {$lcm * $p ** $c}]
}
return $lcm
}
proc qsort {L {left 0} {right -1}} {
set left [expr {int($left)}]
set right [expr {int($right)}]
if {$right < 0} {set right [expr {[llength $L] - 1}]}
set pivot [lindex $L [expr {($left + $right) / 2}]]
set i $left
set j $right
while {$i <= $j} {
set a [lindex $L $i]
set b [lindex $L $j]
while {$a < $pivot} {
set a [lindex $L [incr i]]
}
while {$b > $pivot} {
set b [lindex $L [incr j -1]]
}
if {$i <= $j} {
lset L $i $b
lset L $j $a
incr i
incr j -1
}
}
if { $left < $j } {
set L [qsort $L $left $j]
}
if { $i < $right } {
set L [qsort $L $i $right]
}
return $L
}
proc impure {a b c} {
set x 0
for {set i $a} {$i < $b} {incr i $c} {
set x [expr {$x + $i}]
}
return $x
}
proc impure-typecheck-int {a b c} {
if {[string is int -strict $a]
&& [string is int -strict $b]
&& [string is int -strict $c]} {
set x 0
for {set i $a} {$i < $b} {incr i $c} {
set x [expr {$x + $i}]
}
return $x
} else {
error "type error"
}
}
proc impure2 {a b c} {
set x 0x0
for {set i $a} {$i < $b} {incr i $c} {
set x [expr {$x + $i}]
}
return $x
}
proc impure-caller {} {
impure 10 10000 10
}
proc comps {a b} {
list [string is double -strict $a] \
[expr {$a == $b}] \
[expr {$a eq $b}] \
[expr {$a >= $b}] [expr {[string compare $a $b] >= 0}] \
[expr {$a > $b}] [expr {[string compare $a $b] > 0}] \
[expr {$a <= $b}] [expr {[string compare $a $b] <= 0}] \
[expr {$a < $b}] [expr {[string compare $a $b] < 0}] \
[expr {$a != $b}] \
[expr {$a ne $b}]
}
namespace eval ::bug-7c599d4029 {
proc classify x {
if {[string is integer -strict $x]} {
return [list I $x]
} else {
return [list S $x]
}
}
proc bug {x} {
if {[string is integer -strict $x]} {
set y 1
} else {
set y 0
}
list $y [classify $x]
}
}
namespace eval ::linesearch {
proc colinear {x1 y1 x2 y2 x3 y3} {
expr {$x1*($y2-$y3) + $x2*($y3-$y1) + $x3*($y1-$y2) == 0}
}
proc sameline {x1 y1 x2 y2 x3 y3 x4 y4} {
expr {
[colinear $x1 $y1 $x2 $y2 $x3 $y3]
&& [colinear $x1 $y1 $x2 $y2 $x4 $y4]
}
}
proc getAllLines1 {range} {
set lines {}
for {set x1 0} {$x1<=$range} {incr x1} {
for {set y1 0} {$y1<=$range} {incr y1} {
for {set x2 0} {$x2<=$range} {incr x2} {
for {set y2 0} {$y2<=$range} {incr y2} {
if {$x1==$x2 && $y1==$y2} continue
set present 0
foreach {x3 y3 x4 y4} $lines {
if {[sameline $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4]} {
set present 1
break
}
}
if {!$present} {
lappend lines $x1 $y1 $x2 $y2
}
}
}
}
}
return $lines
}
proc getAllLines2 {range} {
set lines {}
set range [expr {int($range)}]
for {set x1 0} {$x1<=$range} {incr x1} {
for {set y1 0} {$y1<=$range} {incr y1} {
for {set x2 0} {$x2<=$range} {incr x2} {
for {set y2 0} {$y2<=$range} {incr y2} {
if {$x1==$x2 && $y1==$y2} continue
set present 0
foreach {x3 y3 x4 y4} $lines {
set x3 [expr {int($x3)}]
set y3 [expr {int($y3)}]
set x4 [expr {int($x4)}]
set y4 [expr {int($y4)}]
if {[sameline $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4]} {
set present 1
break
}
}
if {!$present} {
lappend lines $x1 $y1 $x2 $y2
}
}
}
}
}
return $lines
}
}
namespace eval ::flightawarebench {
# See https://github.com/flightaware/tclbench/blob/master/math/bench.tcl
proc degrees_radians {degrees} {
return [expr {$degrees * 3.14159265358979323846 / 180.0}]
}
proc latlongs_to_distance {lat1 lon1 lat2 lon2} {
set dLat [degrees_radians [expr {$lat2 - $lat1}]]
set dLon [degrees_radians [expr {$lon2 - $lon1}]]
set lat1 [degrees_radians $lat1]
set lat2 [degrees_radians $lat2]
set a [expr {sin($dLat / 2) ** 2 + sin($dLon / 2) ** 2 * cos($lat1) * cos($lat2)}]
set c [expr {2 * atan2(sqrt($a), sqrt(1 - $a))}]
return [expr {3963. * $c}]
}
proc test {{incrA 1} {incrB 1} {incrC 1}} {
set result {}
for {set lon -180} {$lon < 180} {incr lon $incrA} {
for {set lat -90} {$lat < 90} {incr lat $incrB} {
for {set lon2 40} {$lon2 < 48} {incr lon2 $incrC} {
lappend result [latlongs_to_distance $lat $lon 44 $lon2]
}
}
}
return $result
}
# proc clockscan {{yinc 1} {minc 1} {dinc 1}} {
# set results {}
# return abc
# for {set year 1970} {$year < 2015} {incr year $yinc} {
# for {set month 1} {$month <= 12} {incr month $minc} {
# for {set day 1} {$day <= 28} {incr day $dinc} {
# set result [clock scan "$month/$day/$year 00:00"]
# set fmty [clock format $result -gmt 1]
# lappend results $result $fmty
# #set result2 [clock scan $fmty]
# #lappend list $result $fmty $result2
# }
# }
# }
# return $results
# }
}
proc cleanopt {opt} {
# A simple helper that is not compiled, but rather just shortens code below
dict remove $opt -errorstack -errorinfo
}
#########################################################################
#
# List of demonstration scripts. Each of these will be executed before and
# after having the compilation engine applied; the output values from before
# and after will be compared, and if they match, the performance ratio will be
# computed.
#
# Note that the 'bytes' variable contains a byte array, at least at the start
# of the run for timing (it's *not* reset for each loop of the timing).
set errorCode {}
set demos {
# Mathematical operations; [fib] and [cos] are supposed to be accelerated
# heavily, the others are less critical
{fib 85}
{cos 1.2}
# Fails on a roundoff error: {tantest 1.2}
{inttest 345}
{math::ln_Gamma 1.3}
{polartest 0.6 0.8}
{powmul1 13 3}
{powmul2 13 3}
{uplustest 123 456}
{uplustest 01 010}
{list [catch {uplustest abc def} msg] $msg}
# String operations
{strtest 1 15}
{passthrough;}
{passthrough xyz}
{streqtest abc def}
{strconcattest abc def}
{comparetest 5 5.2}
{appendtest 20}
{appendtest2 20}
{appendtest3 20}
{rev abcdef}
{rev $bytes}
{idx abcdefg}
{ranged abcdefgh}
{substrtest g t}
{substrtest t g}
{substrtest2 b f}
{replacing e k}
{replacing2 abcdefghi}
{replacing2 abcdefghiabcdefghiabcdefghi}
{replacing3 abcdefghijklm}
{matchtest xyzaxyz}
{matchtest xyzaxyzabxyzabcxyz}
{cmptest abc}
{cmptest2 0x10 16}
{cmptest2 0x10 15}
{cmptest2 0e0 .0}
{cmptest2 0e0 0x0}
{trimtest ABCDABC}
{trimtest DABCABCD}
{casetest aBcDe}
{strclasstest abc123}
{strclasstest abc-123}
{concatenater 7}
{list [booltest on] [booltest no] [booltest ""] [booltest fruitbat]}
{stristest ""}
{stristest x}
{stristest 0}
{stristest 1.2}
{stristest 0xAB}
# List operations (also see some [try] tests)
{listtest a b}
{lsetest {a b c d e f}}
{lappendtest {x y z}}
{list [catch {lappendtest "x \{y"} msg] $msg}
{rangetest 1 20}
{lrangetest {a b c d e f}}
{numberitems {a b c d e f}}
{numberitems2 {{a b c} {d e f}}}
{numberitems3 {a b c d e f}}
{doubleitems {a b c d e f}}
{containment {A B C a c e}}
{listjoin1 {a b c d e f g h}}
{listjoin2 {a b c d e f g h}}
{listjoin3 {a b c d e f g h}}
{calltest 1 5 ,}
# Array operations
{wordcounter1 "this is an example and is full of example words"}
{wordcounter2 "this is an example and is full of example words"}
{wordcounter3 "this is an example and is full of example words"}
# Dictionary operations (also see some [try] tests)
{dictest {a b c d foo bar boo boo}}
{dictest {a b c d}}
{dictest2 {a b c d}}
{dictest3 {a b c d}}
{dictest4 p q r q}
{dictest5}
{dictest6}
{dictfor {a b c d e f g h i j}}
# Failure handling, [subst], [try]
{list [catch {switchfail xyz} msg] $msg}
{jumptable a}
{jumptable b}
{jumptable c}
{jumptable xyz}
{wideretest x}
{substtest pqr}
{substtest2 pqr}
{magicreturn 5}
{returntest x bar}
{errortest1 pqr}
{catch {errortest2 pqr}}
{list [catch {errortest2 pqr} msg opt] $msg [cleanopt $opt]}
{errortest2-caller pqr}
{errortest3 pqr}
{errortest3 st}
{list [catch {errortest4 pqr} msg] $msg}
{catch {errortest4 qwe}}
{errortest4 qwerty}
{errortest4a pqr}
{errortest4a qwe}
{errortest4a qwerty}
{errortest5 abc}
{errortest6 1}
{errortest6 2}
{errortest6 3}
{nextest1 0}
{nextest1 1}
{nextest2 0}
{nextest2 1}
{nextest3 0}
{nextest3 1}
{nextest4}
{catch {calltest2 1 5 ,} msg}
{calltest3 0 3}
{coscaller1 1.0471975511965976}
{coscaller2}
{mrtest::calc {/ {* {+ {i 2} {i 3}} {* {f {i 4}} {i 4}}} {i 10}}}
{lcmRange 25}
{xsum2}
{bctest -1}
{bctest 0}
{bctest 1}
{bctest "t"}
{bctest "f"}
{bctest "true"}
{bctest "fish head"}
{asmtest}
{nstest::nstest0}
{nstest::nstest1}
{nstest::nstest2}
{nstest::nstest3}
{nstest::nstest4}
{nstest::nstest5}
{nstest::nstest6}
{list [catch {nstest::nstest7} result] $result $::errorCode}
{bug-0616bcf08e::msrange 0 10}
{bug-0616bcf08e::msrange2 0 10}
{qsort {3 6 8 7 0 1 4 2 9 5}}
{impure 0x0 0 0}
{impure 0x3 0 0}
{impure 0 1 1}
{impure 10 10000 10}
{impure 1 +2000 [string range "123" 2 2]}
{impure-typecheck-int 10 10000 10}
{impure-typecheck-int 1 +2000 [string range "123" 2 2]}
{impure-caller}
{impure2 0x0 0 0}
{impure2 0x3 0 0}
{impure2 0 1 1}
{impure2 10 10000 10}
{impure2 0b1 0x80 0o13}
{comps 1 2}
{comps 2 1}
{comps 0x10 0y2}
{comps 0y2 3}
{comps 3 0x10}
{list [catch {bug-7c599d4029::bug {fish head}} r] $r}
{bug-7c599d4029::bug 1}
{bug-7c599d4029::bug 0x1}
{linesearch::getAllLines1 2}
{linesearch::getAllLines2 2}
# {flightawarebench::test 5 5 2}
# {flightawarebench::clockscan 5 5 5}
}
set demos'slow' {
{flightawarebench::test 5 5 2}
}
#########################################################################
#
# List of procedures to compile. These do not need to be fully-qualified; the
# compilation engine will do that for us if necessary.
set toCompile {
# Mathematical operations; [fib] and [cos] are supposed to be accelerated
# heavily, the others are less critical
fib
::cos
tantest
inttest
math::ln_Gamma
polartest
shift
powmul1 powmul2
uplustest
# String operations
strtest
passthrough
streqtest
strconcattest
comparetest
appendtest appendtest2 appendtest3
rev
idx
ranged
substrtest substrtest2
casetest
cmptest
cmptest2
matchtest
replacing replacing2 replacing3
strclasstest
jumptable
concatenater
booltest
stristest
# Failure handling, [subst], [try]
wideretest
substtest
substtest2
switchfail
trimtest
magicreturn
returntest
errortest1
errortest2
# errortest2-caller BUG: NOTHING ends up in phi node?
errortest3
errortest4 errortest4a
errortest5 errortest6
# List operations (also see some [try] tests)
listtest
lrangetest
listjoin1 listjoin2
listjoin3
lsetest
lappendtest
rangetest
numberitems numberitems2 numberitems3 doubleitems
containment
# Dictionary operations (also see some [try] tests)
dictest
dictest2 dictest3
dictest4 dictest5
dictest6
dictfor
# Nonexistent variables
nextest1
nextest2
nextest3
nextest4
# Array operations
wordcounter1
wordcounter2
wordcounter3
# Calls of uncompiled code
calltest
calltest2
calltest3
# The interprocedural tests
mrtest::*
coscaller1
coscaller2
xsum xsum2
# Namespace tests
nstest::nstest0
nstest::nstest1
# nstest::nstest2 NEEDS CALLFRAME SUPPORT
nstest::nstest3
nstest::nstest4
# nstest::nstest5 NEEDS CALLFRAME SUPPORT
nstest::nstest6
nstest::nstest7
# Miscellaneous other tests
bctest
asmtest
# Combined feature tests
lcmRange
bug-0616bcf08e::*
qsort
impure
impure-caller
impure-typecheck-int
impure2
comps
bug-7c599d4029::*
linesearch::colinear
linesearch::sameline
linesearch::getAllLines1
linesearch::getAllLines2
flightawarebench::*
}
#############################################################################
#
# Demonstration/test running code. In particular, this (effectively) calls:
#
# LLVM configure {*}$argv
# LLVM optimise {*}$toCompile
# foreach script $demos {
# time $script
# }
#
# There's more complexity than that (to do tracking and comparisons of values,
# representations, speed, etc.), but not hugely more. The view above is
# Load the local package and its dependencies
lappend auto_path [file dirname [info script]]
package require tclquadcode
# Load the demo runner support code
source -encoding utf-8 [file join [file dirname [info script]] demosupport.tcl]
# Parse and init the command line arguments
DemoParseArguments
# Run the test cases above in before-and-after-compilation and compare for
# correctness and speed.
DemoCompileAndCompare
# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# End: