mirror of
https://github.com/wfjm/w11.git
synced 2026-05-04 23:26:38 +00:00
123 lines
3.3 KiB
Tcl
123 lines
3.3 KiB
Tcl
# $Id: tbench.tcl 1177 2019-06-30 12:34:07Z mueller $
|
|
# SPDX-License-Identifier: GPL-3.0-or-later
|
|
# Copyright 2013-2019 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
|
|
#
|
|
# Revision History:
|
|
# Date Rev Version Comment
|
|
# 2019-03-03 1117 2.2.1 tbench_list: ignore whitespace and empty lines
|
|
# 2015-05-17 683 2.2 support sub directories and return in tests
|
|
# 2015-05-09 676 2.1 use 'rlc log -bare' instead of 'puts'
|
|
# 2014-11-30 607 2.0 use new rlink v4 iface
|
|
# 2013-04-26 510 1.0 Initial version (extracted from util.tcl)
|
|
#
|
|
|
|
package provide rw11 1.0
|
|
|
|
package require rlink
|
|
package require rwxxtpp
|
|
|
|
namespace eval rw11 {
|
|
|
|
#
|
|
# tbench: driver for tbench scripts
|
|
#
|
|
proc tbench {tname} {
|
|
set fname $tname
|
|
set tbase "."
|
|
if {[string match "@*" $tname]} {
|
|
set fname [string range $tname 1 end]
|
|
}
|
|
if {![file exists $fname]} {set tbase "$::env(RETROBASE)/tools/tbench"}
|
|
|
|
rlink::anena 1; # enable attn notify
|
|
set errcnt [tbench_list $tname $tbase]
|
|
return $errcnt
|
|
}
|
|
|
|
#
|
|
# tbench_file: execute list of tbench steps
|
|
#
|
|
proc tbench_list {tname tbase} {
|
|
set errcnt 0
|
|
|
|
set rname $tname
|
|
set islist 0
|
|
if {[string match "@*" $tname]} {
|
|
set islist 1
|
|
set rname [string range $tname 1 end]
|
|
}
|
|
|
|
set dname [file dirname $rname]
|
|
set fname [file tail $rname]
|
|
if {$dname ne "."} {
|
|
set tbase [file join $tbase $dname]
|
|
}
|
|
|
|
if {![file readable "$tbase/$fname"]} {
|
|
puts "-E: file $tbase/$fname not found or readable"
|
|
error "-E: file $tbase/$fname not found or readable"
|
|
}
|
|
|
|
if {$islist} {
|
|
set fh [open "$tbase/$fname"]
|
|
while {[gets $fh line] >= 0} {
|
|
set line [string trim $line]; # trim white space
|
|
if {$line eq ""} {continue}; # skip empty lines
|
|
if {[string match "#*" $line]} {
|
|
if {[string match "##*" $line]} { rlc log -bare $line }
|
|
} elseif {[string match "@*" $line]} {
|
|
incr errcnt [tbench_list $line $tbase]
|
|
} else {
|
|
incr errcnt [tbench_step $line $tbase]
|
|
}
|
|
}
|
|
close $fh
|
|
|
|
} else {
|
|
incr errcnt [tbench_step $fname $tbase]
|
|
}
|
|
|
|
if {$islist} {
|
|
rlc log -bare [format "%s: %s" $tname [rutil::errcnt2txt $errcnt]]
|
|
}
|
|
return $errcnt
|
|
}
|
|
|
|
#
|
|
# tbench_step: execute single tbench step
|
|
#
|
|
proc tbench_step {fname tbase} {
|
|
if {![file readable "$tbase/$fname"]} {
|
|
error "-E: file $tbase/$fname not found or readable"
|
|
}
|
|
|
|
# cleanup any remaining temporary procs with names tmpproc_*
|
|
foreach pname [info procs tmpproc_*] { rename $pname "" }
|
|
|
|
rlc errcnt -clear
|
|
set cpu "cpu0"
|
|
set ecode [catch "source $tbase/$fname" resmsg]
|
|
set errcnt [rlc errcnt]
|
|
|
|
switch $ecode {
|
|
0 {}
|
|
1 { puts "-E: test execution FAILED with error message:"
|
|
if {[info exists errorInfo]} {puts $errorInfo} else {puts $resmsg}
|
|
incr errcnt
|
|
}
|
|
2 { puts "-I: test ended by return: $resmsg"}
|
|
default {
|
|
puts "-E: test execution FAILED with catch code $ecode"
|
|
incr errcnt
|
|
}
|
|
}
|
|
|
|
# remove temporary procs with names tmpproc_*
|
|
foreach pname [info procs tmpproc_*] { rename $pname "" }
|
|
|
|
rlc log -bare [format "%s: %s" $fname [rutil::errcnt2txt $errcnt]]
|
|
return $errcnt
|
|
}
|
|
|
|
}
|