# $Id: util.tcl 569 2014-07-13 14:36:32Z mueller $
|
# $Id: util.tcl 569 2014-07-13 14:36:32Z mueller $
|
#
|
#
|
# Copyright 2011-2014 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
|
# Copyright 2011-2014 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
|
#
|
#
|
# This program is free software; you may redistribute and/or modify it under
|
# This program is free software; you may redistribute and/or modify it under
|
# the terms of the GNU General Public License as published by the Free
|
# the terms of the GNU General Public License as published by the Free
|
# Software Foundation, either version 2, or at your option any later version.
|
# Software Foundation, either version 2, or at your option any later version.
|
#
|
#
|
# This program is distributed in the hope that it will be useful, but
|
# This program is distributed in the hope that it will be useful, but
|
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
|
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
|
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
# for complete details.
|
# for complete details.
|
#
|
#
|
# Revision History:
|
# Revision History:
|
# Date Rev Version Comment
|
# Date Rev Version Comment
|
# 2014-07-12 569 1.0.2 add sxt16 and sxt32
|
# 2014-07-12 569 1.0.2 add sxt16 and sxt32
|
# 2013-05-09 517 1.0.1 add optlist2arr
|
# 2013-05-09 517 1.0.1 add optlist2arr
|
# 2011-03-27 374 1.0 Initial version
|
# 2011-03-27 374 1.0 Initial version
|
# 2011-03-19 372 0.1 First draft
|
# 2011-03-19 372 0.1 First draft
|
#
|
#
|
|
|
package provide rutil 1.0
|
package provide rutil 1.0
|
|
|
package require rutiltpp
|
package require rutiltpp
|
|
|
namespace eval rutil {
|
namespace eval rutil {
|
#
|
#
|
# optlist2arr: process options arguments given as key value list -----------
|
# optlist2arr: process options arguments given as key value list -----------
|
#
|
#
|
proc optlist2arr {outarrname refarrname optlist} {
|
proc optlist2arr {outarrname refarrname optlist} {
|
upvar $outarrname outarr
|
upvar $outarrname outarr
|
upvar $refarrname refarr
|
upvar $refarrname refarr
|
array set outarr [array get refarr]
|
array set outarr [array get refarr]
|
foreach {key value} $optlist {
|
foreach {key value} $optlist {
|
if {[info exists outarr($key)]} {
|
if {[info exists outarr($key)]} {
|
set outarr($key) $value
|
set outarr($key) $value
|
} else {
|
} else {
|
error "key $key not valid in optlist"
|
error "key $key not valid in optlist"
|
}
|
}
|
}
|
}
|
return ""
|
return ""
|
}
|
}
|
|
|
#
|
#
|
# regdsc: setup a register descriptor --------------------------------------
|
# regdsc: setup a register descriptor --------------------------------------
|
#
|
#
|
proc regdsc {name args} {
|
proc regdsc {name args} {
|
upvar $name rdsc
|
upvar $name rdsc
|
set fbegmax -1
|
set fbegmax -1
|
set mskftot 0
|
set mskftot 0
|
|
|
foreach arg $args {
|
foreach arg $args {
|
set nopt [llength $arg]
|
set nopt [llength $arg]
|
if {$nopt < 2} {
|
if {$nopt < 2} {
|
error "wrong number of elements in field dsc \"$arg\""
|
error "wrong number of elements in field dsc \"$arg\""
|
}
|
}
|
set fnam [lindex $arg 0]
|
set fnam [lindex $arg 0]
|
set fbeg [lindex $arg 1]
|
set fbeg [lindex $arg 1]
|
set flen [lindex $arg 2]
|
set flen [lindex $arg 2]
|
if {$nopt < 3} { set flen 1 }
|
if {$nopt < 3} { set flen 1 }
|
set popt [lindex $arg 3]
|
set popt [lindex $arg 3]
|
if {$nopt < 4} { set popt "b" }
|
if {$nopt < 4} { set popt "b" }
|
|
|
if {( $flen - 1 ) > $fbeg} {
|
if {( $flen - 1 ) > $fbeg} {
|
error "error in field dsc \"$arg\": length > start position"
|
error "error in field dsc \"$arg\": length > start position"
|
}
|
}
|
|
|
set mskb [expr {( 1 << $flen ) - 1}]
|
set mskb [expr {( 1 << $flen ) - 1}]
|
set mskf [expr {$mskb << ( $fbeg - ( $flen - 1 ) )}]
|
set mskf [expr {$mskb << ( $fbeg - ( $flen - 1 ) )}]
|
set rdsc($fnam) [list $fbeg $flen $mskb $mskf $popt]
|
set rdsc($fnam) [list $fbeg $flen $mskb $mskf $popt]
|
|
|
if {$fbegmax < $fbeg} {set fbegmax $fbeg}
|
if {$fbegmax < $fbeg} {set fbegmax $fbeg}
|
set mskftot [expr {$mskftot | $mskf}]
|
set mskftot [expr {$mskftot | $mskf}]
|
}
|
}
|
|
|
set rdsc(-n) [lsort -decreasing -command regdsc_sort \
|
set rdsc(-n) [lsort -decreasing -command regdsc_sort \
|
[array names rdsc -regexp {^[^-]}] ]
|
[array names rdsc -regexp {^[^-]}] ]
|
|
|
set rdsc(-w) [expr {$fbegmax + 1}]
|
set rdsc(-w) [expr {$fbegmax + 1}]
|
set rdsc(-m) $mskftot
|
set rdsc(-m) $mskftot
|
|
|
return ""
|
return ""
|
}
|
}
|
|
|
#
|
#
|
# regdsc_print: print register descriptor ----------------------------------
|
# regdsc_print: print register descriptor ----------------------------------
|
#
|
#
|
proc regdsc_print {name} {
|
proc regdsc_print {name} {
|
upvar $name rdsc
|
upvar $name rdsc
|
set rval ""
|
set rval ""
|
if {! [info exists rdsc]} {
|
if {! [info exists rdsc]} {
|
error "can't access \"$name\": variable doesn't exist"
|
error "can't access \"$name\": variable doesn't exist"
|
}
|
}
|
|
|
set rsize $rdsc(-w)
|
set rsize $rdsc(-w)
|
|
|
append rval " field bits bitmask"
|
append rval " field bits bitmask"
|
|
|
foreach fnam $rdsc(-n) {
|
foreach fnam $rdsc(-n) {
|
set fdsc $rdsc($fnam)
|
set fdsc $rdsc($fnam)
|
set fbeg [lindex $fdsc 0]
|
set fbeg [lindex $fdsc 0]
|
set flen [lindex $fdsc 1]
|
set flen [lindex $fdsc 1]
|
set fmskf [lindex $fdsc 3]
|
set fmskf [lindex $fdsc 3]
|
set line " "
|
set line " "
|
append line [format "%8s" $fnam]
|
append line [format "%8s" $fnam]
|
if {$flen > 1} {
|
if {$flen > 1} {
|
append line [format " %2d:%2d" $fbeg [expr {$fbeg - $flen + 1}]]
|
append line [format " %2d:%2d" $fbeg [expr {$fbeg - $flen + 1}]]
|
} else {
|
} else {
|
append line [format " %2d" $fbeg]
|
append line [format " %2d" $fbeg]
|
}
|
}
|
append line " "
|
append line " "
|
append line [pbvi "b${rsize}" $fmskf]
|
append line [pbvi "b${rsize}" $fmskf]
|
append rval "\n$line"
|
append rval "\n$line"
|
}
|
}
|
return $rval
|
return $rval
|
}
|
}
|
|
|
proc regdsc_sort {a b} {
|
proc regdsc_sort {a b} {
|
upvar rdsc urdsc
|
upvar rdsc urdsc
|
return [expr {[lindex $urdsc($a) 0] - [lindex $urdsc($b) 0] }]
|
return [expr {[lindex $urdsc($a) 0] - [lindex $urdsc($b) 0] }]
|
}
|
}
|
|
|
#
|
#
|
# regbld: build a register value from a list of fields ---------------------
|
# regbld: build a register value from a list of fields ---------------------
|
#
|
#
|
proc regbld {name args} {
|
proc regbld {name args} {
|
upvar $name rdsc
|
upvar $name rdsc
|
set rval 0
|
set rval 0
|
foreach arg $args {
|
foreach arg $args {
|
if {[llength $arg] < 1 || [llength $arg] > 2} {
|
if {[llength $arg] < 1 || [llength $arg] > 2} {
|
error "error in field specifier \"$arg\": must be 'name [val]'"
|
error "error in field specifier \"$arg\": must be 'name [val]'"
|
}
|
}
|
set fnam [lindex $arg 0]
|
set fnam [lindex $arg 0]
|
if {! [info exists rdsc($fnam)] } {
|
if {! [info exists rdsc($fnam)] } {
|
error "error in field specifier \"$arg\": field unknown"
|
error "error in field specifier \"$arg\": field unknown"
|
}
|
}
|
set fbeg [lindex $rdsc($fnam) 0]
|
set fbeg [lindex $rdsc($fnam) 0]
|
set flen [lindex $rdsc($fnam) 1]
|
set flen [lindex $rdsc($fnam) 1]
|
|
|
if {[llength $arg] == 1} {
|
if {[llength $arg] == 1} {
|
if {$flen > 1} {
|
if {$flen > 1} {
|
error "error in field specifier \"$arg\": no value and flen>1"
|
error "error in field specifier \"$arg\": no value and flen>1"
|
}
|
}
|
set mskf [lindex $rdsc($fnam) 3]
|
set mskf [lindex $rdsc($fnam) 3]
|
set rval [expr {$rval | $mskf}]
|
set rval [expr {$rval | $mskf}]
|
|
|
} else {
|
} else {
|
set fval [lindex $arg 1]
|
set fval [lindex $arg 1]
|
set mskb [lindex $rdsc($fnam) 2]
|
set mskb [lindex $rdsc($fnam) 2]
|
if {$fval >= 0} {
|
if {$fval >= 0} {
|
if {$fval > $mskb} {
|
if {$fval > $mskb} {
|
error "error in field specifier \"$arg\": value > $mskb"
|
error "error in field specifier \"$arg\": value > $mskb"
|
}
|
}
|
} else {
|
} else {
|
if {$fval < [expr {- $mskb}]} {
|
if {$fval < [expr {- $mskb}]} {
|
error "error in field specifier \"$arg\": value < [expr -$mskb]"
|
error "error in field specifier \"$arg\": value < [expr -$mskb]"
|
}
|
}
|
set fval [expr {$fval & $mskb}]
|
set fval [expr {$fval & $mskb}]
|
}
|
}
|
set rval [expr {$rval | $fval << ( $fbeg - ( $flen - 1 ) )}]
|
set rval [expr {$rval | $fval << ( $fbeg - ( $flen - 1 ) )}]
|
}
|
}
|
|
|
}
|
}
|
return $rval
|
return $rval
|
}
|
}
|
|
|
#
|
#
|
# regget: extract field from a register value ------------------------------
|
# regget: extract field from a register value ------------------------------
|
#
|
#
|
proc regget {name val} {
|
proc regget {name val} {
|
upvar $name fdsc
|
upvar $name fdsc
|
set fbeg [lindex $fdsc 0]
|
set fbeg [lindex $fdsc 0]
|
set flen [lindex $fdsc 1]
|
set flen [lindex $fdsc 1]
|
set mskb [lindex $fdsc 2]
|
set mskb [lindex $fdsc 2]
|
return [expr {( $val >> ( $fbeg - ( $flen - 1 ) ) ) & $mskb}]
|
return [expr {( $val >> ( $fbeg - ( $flen - 1 ) ) ) & $mskb}]
|
}
|
}
|
|
|
#
|
#
|
# regtxt: convert register value to a text string --------------------------
|
# regtxt: convert register value to a text string --------------------------
|
#
|
#
|
proc regtxt {name val} {
|
proc regtxt {name val} {
|
upvar $name rdsc
|
upvar $name rdsc
|
set rval ""
|
set rval ""
|
|
|
foreach fnam $rdsc(-n) {
|
foreach fnam $rdsc(-n) {
|
set popt [lindex $rdsc($fnam) 4]
|
set popt [lindex $rdsc($fnam) 4]
|
set fval [regget rdsc($fnam) $val]
|
set fval [regget rdsc($fnam) $val]
|
if {$popt ne "-"} {
|
if {$popt ne "-"} {
|
if {$rval ne ""} {append rval " "}
|
if {$rval ne ""} {append rval " "}
|
append rval "${fnam}:"
|
append rval "${fnam}:"
|
if {$popt eq "b"} {
|
if {$popt eq "b"} {
|
set flen [lindex $rdsc($fnam) 1]
|
set flen [lindex $rdsc($fnam) 1]
|
append rval [pbvi b${flen} $fval]
|
append rval [pbvi b${flen} $fval]
|
} else {
|
} else {
|
append rval [format "%${popt}" $fval]
|
append rval [format "%${popt}" $fval]
|
}
|
}
|
}
|
}
|
}
|
}
|
return $rval
|
return $rval
|
}
|
}
|
#
|
#
|
# errcnt2txt: returns "PASS" if 0 and "FAIL" otherwise ---------------------
|
# errcnt2txt: returns "PASS" if 0 and "FAIL" otherwise ---------------------
|
#
|
#
|
proc errcnt2txt {errcnt} {
|
proc errcnt2txt {errcnt} {
|
if {$errcnt} {return "FAIL"}
|
if {$errcnt} {return "FAIL"}
|
return "PASS"
|
return "PASS"
|
}
|
}
|
#
|
#
|
# sxt16: 16 bit sign extend ------------------------------------------------
|
# sxt16: 16 bit sign extend ------------------------------------------------
|
#
|
#
|
proc sxt16 {val} {
|
proc sxt16 {val} {
|
if {$val & 0x8000} { # bit 15 set ?
|
if {$val & 0x8000} { # bit 15 set ?
|
set val [expr $val | ~ 077777]; # --> set bits 15 and higher
|
set val [expr $val | ~ 077777]; # --> set bits 15 and higher
|
}
|
}
|
return $val
|
return $val
|
}
|
}
|
|
|
#
|
#
|
# sxt32: 32 bit sign extend ------------------------------------------------
|
# sxt32: 32 bit sign extend ------------------------------------------------
|
#
|
#
|
proc sxt32 {val} {
|
proc sxt32 {val} {
|
if {$val & 0x80000000} { # bit 31 set ?
|
if {$val & 0x80000000} { # bit 31 set ?
|
set val [expr $val | ~ 017777777777]; # --> set bits 31 and higher
|
set val [expr $val | ~ 017777777777]; # --> set bits 31 and higher
|
}
|
}
|
return $val
|
return $val
|
}
|
}
|
|
|
#
|
#
|
# ! export reg... procs to global scope ------------------------------------
|
# ! export reg... procs to global scope ------------------------------------
|
#
|
#
|
|
|
namespace export regdsc
|
namespace export regdsc
|
namespace export regdsc_print
|
namespace export regdsc_print
|
namespace export regbld
|
namespace export regbld
|
namespace export regget
|
namespace export regget
|
namespace export regtxt
|
namespace export regtxt
|
}
|
}
|
|
|
namespace import rutil::regdsc
|
namespace import rutil::regdsc
|
namespace import rutil::regdsc_print
|
namespace import rutil::regdsc_print
|
namespace import rutil::regbld
|
namespace import rutil::regbld
|
namespace import rutil::regget
|
namespace import rutil::regget
|
namespace import rutil::regtxt
|
namespace import rutil::regtxt
|
|
|
