merge 8.5

1 files changed, 62 insertions, 16 deletions

diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl
index 4629cd4..99a4e47 100644
--- a/tests-perf/test-performance.tcl
+++ b/tests-perf/test-performance.tcl
@@ -94,51 +94,97 @@ proc _test_out_total {} {
   puts [lindex $_(itm) $maxi]
   puts [string repeat ** 40]
   puts ""
+  unset -nocomplain _(itm) _(starttime)
+}
+
+proc _test_start {reptime} {
+  upvar _ _
+  array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0]
+}
+
+proc _test_iter {args} {
+  if {[llength $args] > 2} {
+    return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\""
+  }
+  set lvl 1
+  if {[llength $args] > 1} {
+    set args [lassign $args lvl]
+  }
+  upvar $lvl _ _
+  puts [set _(m) {*}$args]
+  lappend _(itm) $_(m)
+  puts ""
+}
+
+proc _adjust_maxcount {reptime maxcount} {
+  if {[llength $reptime] > 1} {
+    lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}]
+  } else {
+    lappend reptime $maxcount
+  }
 }
 
 proc _test_run {args} {
   upvar _ _
   # parse args:
-  set _(out-result) 1
-  if {[lindex $args 0] eq "-no-result"} {
-    set _(out-result) 0
+  array set _ [set _opts {-no-result 0 -uplevel 0}]
+  while {[llength $args] > 2} {
+    if {[set o [lindex $args 0]] ni $_opts || $_($o)} {
+      break
+    }
+    set _($o) 1
     set args [lrange $args 1 end]
   }
+  unset -nocomplain _opts o
   if {[llength $args] < 2 || [llength $args] > 3} {
     return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
   }
-  set outcmd {puts $_(r)}
+  set _(outcmd) {puts}
   set args [lassign $args reptime lst]
   if {[llength $args]} {
-    set outcmd [lindex $args 0]
+    set _(outcmd) [lindex $args 0]
   }
   # avoid output if only once:
   if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
-    set _(out-result) 0
+    set _(-no-result) 1
+  }
+  if {![info exists _(itm)]} {
+    array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1]
+  } else {
+    array set _ [list reptime $reptime]
   }
-  array set _ [list itm {} reptime $reptime starttime [clock milliseconds]]
 
   # process measurement:
   foreach _(c) [_test_get_commands $lst] {
-    puts "% [regsub -all {\n[ \t]*} $_(c) {; }]"
+    {*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
     if {[regexp {^\s*\#} $_(c)]} continue
     if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
-      puts [if 1 [lindex $_(c) 1]]
+      set _(c) [lindex $_(c) 1]
+      if {$_(-uplevel)} {
+        set _(c) [list uplevel 1 $_(c)]
+      }
+      {*}$_(outcmd) [if 1 $_(c)]
       continue
     }
+    if {$_(-uplevel)} {
+      set _(c) [list uplevel 1 $_(c)]
+    }
+    set _(ittime) $_(reptime)
     # if output result (and not once):
-    if {$_(out-result)} {
+    if {!$_(-no-result)} {
       set _(r) [if 1 $_(c)]
-      if {$outcmd ne {}} $outcmd
-      if {[llength $_(reptime)] > 1} { # decrement max-count
-        lset _(reptime) 1 [expr {[lindex $_(reptime) 1] - 1}]
+      if {$_(outcmd) ne {}} {{*}$_(outcmd) $_(r)}
+      if {[llength $_(ittime)] > 1} { # decrement max-count
+        lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
       }
     }
-    puts [set _(m) [timerate $_(c) {*}$_(reptime)]]
+    {*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
     lappend _(itm) $_(m)
-    puts ""
+    {*}$_(outcmd) ""
+  }
+  if {$_(-from-run)} {
+    _test_out_total
   }
-  _test_out_total
 }
 
 }; # end of namespace ::tclTestPerf