URL
https://opencores.org/ocsvn/w11/w11/trunk
Subversion Repositories w11
Compare Revisions
- This comparison shows the changes necessary to convert path
/w11/tags/w11a_V0.61/tools/tcl/rutil
- from Rev 25 to Rev 26
- ↔ Reverse comparison
Rev 25 → Rev 26
/util.tcl
0,0 → 1,243
# $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> |
# |
# 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 |
# 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 |
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY |
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
# for complete details. |
# |
# Revision History: |
# Date Rev Version Comment |
# 2014-07-12 569 1.0.2 add sxt16 and sxt32 |
# 2013-05-09 517 1.0.1 add optlist2arr |
# 2011-03-27 374 1.0 Initial version |
# 2011-03-19 372 0.1 First draft |
# |
|
package provide rutil 1.0 |
|
package require rutiltpp |
|
namespace eval rutil { |
# |
# optlist2arr: process options arguments given as key value list ----------- |
# |
proc optlist2arr {outarrname refarrname optlist} { |
upvar $outarrname outarr |
upvar $refarrname refarr |
array set outarr [array get refarr] |
foreach {key value} $optlist { |
if {[info exists outarr($key)]} { |
set outarr($key) $value |
} else { |
error "key $key not valid in optlist" |
} |
} |
return "" |
} |
|
# |
# regdsc: setup a register descriptor -------------------------------------- |
# |
proc regdsc {name args} { |
upvar $name rdsc |
set fbegmax -1 |
set mskftot 0 |
|
foreach arg $args { |
set nopt [llength $arg] |
if {$nopt < 2} { |
error "wrong number of elements in field dsc \"$arg\"" |
} |
set fnam [lindex $arg 0] |
set fbeg [lindex $arg 1] |
set flen [lindex $arg 2] |
if {$nopt < 3} { set flen 1 } |
set popt [lindex $arg 3] |
if {$nopt < 4} { set popt "b" } |
|
if {( $flen - 1 ) > $fbeg} { |
error "error in field dsc \"$arg\": length > start position" |
} |
|
set mskb [expr {( 1 << $flen ) - 1}] |
set mskf [expr {$mskb << ( $fbeg - ( $flen - 1 ) )}] |
set rdsc($fnam) [list $fbeg $flen $mskb $mskf $popt] |
|
if {$fbegmax < $fbeg} {set fbegmax $fbeg} |
set mskftot [expr {$mskftot | $mskf}] |
} |
|
set rdsc(-n) [lsort -decreasing -command regdsc_sort \ |
[array names rdsc -regexp {^[^-]}] ] |
|
set rdsc(-w) [expr {$fbegmax + 1}] |
set rdsc(-m) $mskftot |
|
return "" |
} |
|
# |
# regdsc_print: print register descriptor ---------------------------------- |
# |
proc regdsc_print {name} { |
upvar $name rdsc |
set rval "" |
if {! [info exists rdsc]} { |
error "can't access \"$name\": variable doesn't exist" |
} |
|
set rsize $rdsc(-w) |
|
append rval " field bits bitmask" |
|
foreach fnam $rdsc(-n) { |
set fdsc $rdsc($fnam) |
set fbeg [lindex $fdsc 0] |
set flen [lindex $fdsc 1] |
set fmskf [lindex $fdsc 3] |
set line " " |
append line [format "%8s" $fnam] |
if {$flen > 1} { |
append line [format " %2d:%2d" $fbeg [expr {$fbeg - $flen + 1}]] |
} else { |
append line [format " %2d" $fbeg] |
} |
append line " " |
append line [pbvi "b${rsize}" $fmskf] |
append rval "\n$line" |
} |
return $rval |
} |
|
proc regdsc_sort {a b} { |
upvar rdsc urdsc |
return [expr {[lindex $urdsc($a) 0] - [lindex $urdsc($b) 0] }] |
} |
|
# |
# regbld: build a register value from a list of fields --------------------- |
# |
proc regbld {name args} { |
upvar $name rdsc |
set rval 0 |
foreach arg $args { |
if {[llength $arg] < 1 || [llength $arg] > 2} { |
error "error in field specifier \"$arg\": must be 'name [val]'" |
} |
set fnam [lindex $arg 0] |
if {! [info exists rdsc($fnam)] } { |
error "error in field specifier \"$arg\": field unknown" |
} |
set fbeg [lindex $rdsc($fnam) 0] |
set flen [lindex $rdsc($fnam) 1] |
|
if {[llength $arg] == 1} { |
if {$flen > 1} { |
error "error in field specifier \"$arg\": no value and flen>1" |
} |
set mskf [lindex $rdsc($fnam) 3] |
set rval [expr {$rval | $mskf}] |
|
} else { |
set fval [lindex $arg 1] |
set mskb [lindex $rdsc($fnam) 2] |
if {$fval >= 0} { |
if {$fval > $mskb} { |
error "error in field specifier \"$arg\": value > $mskb" |
} |
} else { |
if {$fval < [expr {- $mskb}]} { |
error "error in field specifier \"$arg\": value < [expr -$mskb]" |
} |
set fval [expr {$fval & $mskb}] |
} |
set rval [expr {$rval | $fval << ( $fbeg - ( $flen - 1 ) )}] |
} |
|
} |
return $rval |
} |
|
# |
# regget: extract field from a register value ------------------------------ |
# |
proc regget {name val} { |
upvar $name fdsc |
set fbeg [lindex $fdsc 0] |
set flen [lindex $fdsc 1] |
set mskb [lindex $fdsc 2] |
return [expr {( $val >> ( $fbeg - ( $flen - 1 ) ) ) & $mskb}] |
} |
|
# |
# regtxt: convert register value to a text string -------------------------- |
# |
proc regtxt {name val} { |
upvar $name rdsc |
set rval "" |
|
foreach fnam $rdsc(-n) { |
set popt [lindex $rdsc($fnam) 4] |
set fval [regget rdsc($fnam) $val] |
if {$popt ne "-"} { |
if {$rval ne ""} {append rval " "} |
append rval "${fnam}:" |
if {$popt eq "b"} { |
set flen [lindex $rdsc($fnam) 1] |
append rval [pbvi b${flen} $fval] |
} else { |
append rval [format "%${popt}" $fval] |
} |
} |
} |
return $rval |
} |
# |
# errcnt2txt: returns "PASS" if 0 and "FAIL" otherwise --------------------- |
# |
proc errcnt2txt {errcnt} { |
if {$errcnt} {return "FAIL"} |
return "PASS" |
} |
# |
# sxt16: 16 bit sign extend ------------------------------------------------ |
# |
proc sxt16 {val} { |
if {$val & 0x8000} { # bit 15 set ? |
set val [expr $val | ~ 077777]; # --> set bits 15 and higher |
} |
return $val |
} |
|
# |
# sxt32: 32 bit sign extend ------------------------------------------------ |
# |
proc sxt32 {val} { |
if {$val & 0x80000000} { # bit 31 set ? |
set val [expr $val | ~ 017777777777]; # --> set bits 31 and higher |
} |
return $val |
} |
|
# |
# ! export reg... procs to global scope ------------------------------------ |
# |
|
namespace export regdsc |
namespace export regdsc_print |
namespace export regbld |
namespace export regget |
namespace export regtxt |
} |
|
namespace import rutil::regdsc |
namespace import rutil::regdsc_print |
namespace import rutil::regbld |
namespace import rutil::regget |
namespace import rutil::regtxt |
/.cvsignore
0,0 → 1,243
pkgIndex.tcl |
.
Property changes :
Added: svn:ignore
## -0,0 +1,34 ##
+*.dep_ghdl
+*.dep_isim
+*.dep_xst
+work-obj93.cf
+*.vcd
+*.ghw
+*.sav
+*.tmp
+*.exe
+ise
+xflow.his
+*.ngc
+*.ncd
+*.pcf
+*.bit
+*.msk
+isim
+isim.log
+isim.wdb
+fuse.log
+*_[sft]sim.vhd
+*_tsim.sdf
+*_xst.log
+*_tra.log
+*_twr.log
+*_map.log
+*_par.log
+*_tsi.log
+*_pad.log
+*_bgn.log
+*_svn.log
+*_sum.log
+*_[dsft]sim.log
+pkgIndex.tcl