set batchmode 0
set benchmarks {}

proc bench {title script} {
    global benchmarks batchmode

    set Title [string range "$title                     " 0 20]

    set failed [catch {time $script} res]
    if {$failed} {
        if {!$batchmode} {puts "$Title - This test can't run on this interpreter -- $res -- $::errorInfo"}
        lappend benchmarks $title F
    } else {
        set t [lindex $res 0]
        lappend benchmarks $title $t
        set ts "          $t"
        set ts [string range $ts [expr {[string length $ts]-10}] end]
        if {!$batchmode} {puts "$Title -$ts microseconds per iteration"}
    }
}

if [llength [info command p7proc]] {
### BUSY LOOP ##################################################################

p7proc (void)whilebusyloop {} {
    set (int)i 0
    while ($i < 1850000) {
	incr i
    }
}

p7proc (void)forbusyloop {} {
    for {set (int)i 0} ($i < 1850000) {incr i} {}
}

### FIBONACCI ##################################################################

p7proc (int)fibonacci {(int)x} {
    if ($x <= 1) {
	return (1)
    } else {
    	return ( [fibonacci ($x-1)] + [fibonacci ($x-2)] )
    }
}

### HEAPSORT ###################################################################

set IM 139968
set IA   3877
set IC  29573

p7global (int)last  ;  p7proc (void)last_INIT {} { set last (42) }

proc make_gen_random {} {
    global IM IA IC
    set params [list IM $IM IA $IA IC $IC]
    set body [string map $params {
        #global last
        set last (($last * IA + IC) % IM)
        return (($max * $last) / IM)
    }]
    puts stderr "p7proc (double)gen_random {(double)max} $body"
    p7proc (double)gen_random {(double)max} $body
}

p7proc (void)heapsort {(double*)ra} {
    #upvar 1 $ra_name ra
    set (int)n [len $ra]
    set (int)l ($n / 2)
    set (int)ir ($n - 1)
    while 1 {
        if ($l) {
            set (double)rra $ra([incr l (0-1)])
        } else {
	    set rra $ra($ir)
	    set ra($ir) $ra(0)
	    if ([incr ir (0-1)] == 0) {
                set ra(0) $rra
		break
            }
        }
	set (int)i $l
	set (int)j ((2 * $l) + 1)
        while ($j <= $ir) {
	    set (double)tmp $ra($j)
	    if ($j < $ir) {
		if ($tmp < $ra( $j + 1 )) {
		    set tmp $ra([incr j])
		}
	    }
            if ($rra >= $tmp) {
		break
	    }
	    set ra($i) $tmp
	    set i $j ; incr j $i
        }
        set ra($i) $rra
    }
}

make_gen_random
p7proc (void)heapsort_main {} {
    set (int)n 6100

    new (double*)data $n
    for {set (int)i 0} ($i < $n) {incr i} {
	set data($i) [gen_random "1.0"]
    }
    heapsort $data
}

### SIEVE ######################################################################

p7proc (int)sieve {(int)num} {
    new (int*)flags 8193
    while ($num > 0) {
	incr num (0-1)
	set (int)count 0
	for {set (int)i 2} ($i <= 8192) {incr i} {
	    set flags($i) 1
	}
	for {set i 2} ($i <= 8192) {incr i} {
	    if ($flags($i) == 1) {
		# remove all multiples of prime: i
		for {set (int)k ($i+$i)} ($k <= 8192) {incr k $i} {
		    set flags($k) 0
		}
		incr count
	    }
	}
    }
    return $count
}

proc sieve_dict {num} {
    while {$num > 0} {
	incr num (0-1)
	set count 0
	for {set i 2} {$i <= 8192} {incr i} {
	    dict set flags $i 1
	}
	for {set i 2} {$i <= 8192} {incr i} {
	    if {[dict get $flags $i] == 1} {
		# remove all multiples of prime: i
		for {set k [expr {$i+$i}]} {$k <= 8192} {incr k $i} {
		    dict set flags $k 0
		}
		incr count
	    }
	}
    }
    return $count
}

### ARY ########################################################################

p7proc (void)ary (int)n {
    for {set (int)i 0} ($i < $n) {incr i} {
	::set "x($i)" $i
    }
    set (int)last ($n - 1)
    for {set (int)j $last} ($j >= 0) {incr j (0-1)} {
	::set "y($j)" [::set "x($j)"]
    }
}

### REPEAT #####################################################################

p7proc (void)repeat {(int)n (tcl)body} {
    for {set (int)i 0} ($i < $n) {incr i} {
	::eval $body
    }
}

p7global (int)x   ;# lambda cannot use locals yet, so use global.
p7proc (void)use_repeat {} {
    set x 0
    repeat {1000000} [lambda {incr x; return $x}]
}

### UPVAR ######################################################################

p7class IntHolder { (int)value }
p7proc (int)myincr (IntHolder)this {
    incr value
    k $value
}

p7proc (void)upvartest {} {
    new (IntHolder)x
    new (IntHolder)y
    for {set x(value) 0} ($x(value) < 100000) {myincr $x} {
	myincr $y
    }
}

### NESTED LOOPS ###############################################################

p7proc (void)nestedloops {} {
    set (int)n 10
    set (int)x 0
    incr n 1
    set (int)a $n
    while ([incr a (0-1)]) {
	set (int)b $n
	while ([incr b (0-1)]) {
	    set (int)c $n
	    while ([incr c (0-1)]) {
		set (int)d $n
		while ([incr d (0-1)]) {
		    set (int)e $n
		    while ([incr e (0-1)]) {
			set (int)f $n
			while ([incr f (0-1)]) {
			    incr x
			}
		    }
		}
	    }
	}
    }
}

### ROTATE #####################################################################

proc (void)rotate {count} {
    set (int)v 1
    for {set (int)n 0} ($n < $count) {incr n} {
    	set v (v << 1 ) ;#-- wtf is <<<? -- set v [expr {$v <<< 1}]
    }
}

### DYNAMICALLY GENERATED CODE #################################################

p7proc (void)dyncode {} {
    for {set (int)i 0} ($i < 100000) {incr i} {
        set (tcl)script "::lappend foo $i"
        ::eval $script
    }
}

p7proc (void)dyncode_list {} {
    for {set (int)i 0} ($i < 100000) {incr i} {
        set (tcl)script [::list lappend foo $i]
        ::eval $script
    }
}

### PI DIGITS ##################################################################

p7proc (void)pi_digits {} {
    set (int)N 300
    set (int)LEN  (10*$N/3)
    set (tcl)result ""

    new (int*)a $LEN
    loop (int)_ $LEN { set a($_) 2 }
    set (tcl)nines 0
    set (int)predigit 0
    set nines {}

    set (int)i0 ( $LEN+1 )
    set (int)quot0 ( 2*$LEN+1 )
    for {set (int)j 0} ($j<$N) {incr j} {
        set (int)q 0
        set (int)i $i0
        set (int)quot $quot0
        set (int)pos (0-1)
        loop _ [len $a] { set (int)apos $a($_)
            set (int)x ( 10*$apos + $q * [incr i (0-1); k $i] )
            set a([incr pos; k $pos]) ($x % [incr quot (0-2); k $quot ])
            set q ($x / $quot)
        }
        set a([len $a]-1) ($q % 10)
        set q ($q / 10)
        if ($q < 8) {
            append result $predigit 
            append result $nines
            set nines {}
            set predigit $q
        } elseif ($q == 9) {
            append nines 9
        } else {
            append result ($predigit+1) 
            append result [::string map {9 0} $nines]
            set nines {}
            set predigit 0
        }
    }
    #puts $result$predigit
}

### EXPAND #####################################################################

proc expand {} {
    for {set i 0} {$i < 100000} {incr i} {
        set a [list a b c d e f]
        lappend b {expand}$a
    }
}

### MINLOOPS ###################################################################

p7proc (void)miniloops {} {
    loop (int)i 100000 {
        set (int)sum 0
        loop (int)j 10 {
            # something of more or less real
            incr sum $j
        }
    }
}

### wiki.tcl.tk/8566 ###########################################################

 # Internal procedure that indexes into the 2-dimensional array t,
 # which corresponds to the sequence y, looking for the (i,j)th element.

 proc Index { t y i j } {
     set indx [expr { ([llength $y] + 1) * ($i + 1) + ($j + 1) }]
     return [lindex $t $indx]
 }

 # Internal procedure that implements Levenshtein to derive the longest
 # common subsequence of two lists x and y.

 proc ComputeLCS { x y } {
     set t [list]
     for { set i -1 } { $i < [llength $y] } { incr i } {
         lappend t 0
     }
     for { set i 0 } { $i < [llength $x] } { incr i } {
         lappend t 0
         for { set j 0 } { $j < [llength $y] } { incr j } {
             if { [string equal [lindex $x $i] [lindex $y $j]] } {
                 set lastT [Index $t $y [expr { $i - 1 }] [expr {$j - 1}]]
                 set nextT [expr {$lastT + 1}]
             } else {
                 set lastT1 [Index $t $y $i [expr { $j - 1 }]]
                 set lastT2 [Index $t $y [expr { $i - 1 }] $j]
                 if { $lastT1 > $lastT2 } {
                     set nextT $lastT1
                 } else {
                     set nextT $lastT2
                 }
             }
             lappend t $nextT
         }
     }
     return $t
 }

 # Internal procedure that traces through the array built by ComputeLCS
 # and finds a longest common subsequence -- specifically, the one that
 # is lexicographically first.

 proc TraceLCS { t x y } {
     set trace {}
     set i [expr { [llength $x] - 1 }]
     set j [expr { [llength $y] - 1 }]
     set k [expr { [Index $t $y $i $j] - 1 }]
     while { $i >= 0 && $j >= 0 } {
         set im1 [expr { $i - 1 }]
         set jm1 [expr { $j - 1 }]
         if { [Index $t $y $i $j] == [Index $t $y $im1 $jm1] + 1
              && [string equal [lindex $x $i] [lindex $y $j]] } {
             lappend trace xy [list $i $j]
             set i $im1
             set j $jm1
         } elseif { [Index $t $y $im1 $j] > [Index $t $y $i $jm1] } {
             lappend trace x $i
             set i $im1
         } else {
             lappend trace y $j
             set j $jm1
         }
     }
     while { $i >= 0 } {
         lappend trace x $i
         incr i -1
     }
     while { $j >= 0 } {
         lappend trace y $j
         incr j -1
     }
     return $trace
 }

 # list::longestCommonSubsequence::compare --
 #
 #       Compare two lists for the longest common subsequence
 #
 # Arguments:
 #       x, y - Two lists of strings to compare
 #       matched - Callback to execute on matched elements, see below
 #       unmatchedX - Callback to execute on unmatched elements from the
 #                    first list, see below.
 #       unmatchedY - Callback to execute on unmatched elements from the
 #                    second list, see below.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       Whatever the callbacks do.
 #
 # The 'compare' procedure compares the two lists of strings, x and y.
 # It finds a longest common subsequence between the two.  It then walks
 # the lists in order and makes the following callbacks:
 #
 # For an element that is common to both lists, it appends the index in
 # the first list, the index in the second list, and the string value of
 # the element as three parameters to the 'matched' callback, and executes
 # the result.
 #
 # For an element that is in the first list but not the second, it appends
 # the index in the first list and the string value of the element as two
 # parameters to the 'unmatchedX' callback and executes the result.
 #
 # For an element that is in the second list but not the first, it appends
 # the index in the second list and the string value of the element as two
 # parameters to the 'unmatchedY' callback and executes the result.

 proc compare { x y
                                                matched
                                                unmatchedX unmatchedY } {
     set t [ComputeLCS $x $y]
     set trace [TraceLCS $t $x $y]
     set i [llength $trace]
     while { $i > 0 } {
         set indices [lindex $trace [incr i -1]]
         set type [lindex $trace [incr i -1]]
         switch -exact -- $type {
             xy {
                 set c $matched
                 eval lappend c $indices
                 lappend c [lindex $x [lindex $indices 0]]
                 uplevel 1 $c
             }
             x {
                 set c $unmatchedX
                 lappend c $indices
                 lappend c [lindex $x $indices]
                 uplevel 1 $c
             }
             y {
                 set c $unmatchedY
                 lappend c $indices
                 lappend c [lindex $y $indices]
                 uplevel 1 $c
             }
         }
     }
     return
 }

 proc umx { index value } {
     global lastx
     global xlines
     append xlines "< " $value \n
     set lastx $index
 }

 proc umy { index value } {
     global lasty
     global ylines
     append ylines "> " $value \n
     set lasty $index
 }

 proc matched { index1 index2 value } {
     global lastx
     global lasty
     global xlines
     global ylines
     if { [info exists lastx] && [info exists lasty] } {
     #puts "[expr { $lastx + 1 }],${index1}c[expr {$lasty + 1 }],${index2}"
     #puts -nonewline $xlines
     #puts "----"
     #puts -nonewline $ylines
     } elseif { [info exists lastx] } {
     #puts "[expr { $lastx + 1 }],${index1}d${index2}"
     #puts -nonewline $xlines
     } elseif { [info exists lasty] } {
     #puts  "${index1}a[expr {$lasty + 1 }],${index2}"
     #puts -nonewline $ylines
     }
     catch { unset lastx }
     catch { unset xlines }
     catch { unset lasty }
     catch { unset ylines }
 }

 # Really, we should read the first file in like this:
 #    set f0 [open [lindex $argv 0] r]
 #    set x [split [read $f0] \n]
 #    close $f0
 # But I'll just provide some sample lines:

proc commonsub_test {} {
 set x {}
 for { set i 0 } { $i < 20 } { incr i } {
     lappend x a r a d e d a b r a x
 }

 # The second file, too, should be read in like this:
 #    set f1 [open [lindex $argv 1] r]
 #    set y [split [read $f1] \n]
 #    close $f1
 # Once again, I'll just do some sample lines.

 set y {}
 for { set i 0 } { $i < 20 } { incr i } {
     lappend y a b r a c a d a b r a
 }

 compare $x $y matched umx umy
 matched [llength $x] [llength $y] {}
}

### MANDEL #####################################################################

p7proc (void)mandel {(double)xres (double)yres (double)infx (double)infy (double)supx (double)supy} {
    set (double)incremx ((0+$supx-$infx)/$xres)
    set (double)incremy ((0+$supy-$infy)/$yres)

    for {set (int)j 0} ($j < $yres) {incr j} {
	set (double)cim ($infy+($incremy*$j))
	set (tcl)line {}
	for {set (int)i 0} ($i < $xres) {incr i} {
	    set (int)counter 0
	    set (double)zim 0
	    set (double)zre 0
	    set (double)cre ($infx+($incremx*$i))
	    while ($counter < 255) {
		set (double)dam ($zre*$zre-$zim*$zim+$cre)
		set zim (2*$zim*$zre+$cim)
		set zre $dam
		if ($zre*$zre+$zim*$zim > 4) { break }
		incr counter
	    }
	    # output pixel $i $j
	}
    }
}

} else {
### RUN ALL ####################################################################
load [lindex [glob ./bench*.so] 0]

if {[string compare [lindex $argv 0] "-batch"] == 0} {
    set batchmode 1
}

bench {[while] busy loop} {whilebusyloop}
bench {[for] busy loop} {forbusyloop}
bench {mini loops} {miniloops}
bench {fibonacci(25)} {fibonacci 25}
bench {heapsort} {heapsort_main}
bench {sieve} {sieve 10}
#bench {sieve [dict]} {sieve_dict 10}
bench {ary} {ary 100000}
bench {repeat} {use_repeat}
bench {upvar} {upvartest}
bench {nested loops} {nestedloops}
#bench {rotate} {rotate 100000}
bench {dynamic code} {dyncode}
bench {dynamic code (list)} {dyncode_list}
bench {PI digits} {pi_digits}
#bench {expand} {expand}
bench {wiki.tcl.tk/8566} {commonsub_test}
bench {mandel} {mandel 60 60 -2 -1.5 1 1.5}

proc istcl {} {
    return [expr {![catch {info tclversion}]}]
}

if {$batchmode} {
    if {[catch {info patchlevel} ver]} {
        set ver Jim[info version]
    }
    puts [list $ver $benchmarks]
}
}