OpenCores
URL https://opencores.org/ocsvn/w11/w11/trunk

Subversion Repositories w11

[/] [w11/] [tags/] [w11a_V0.7/] [tools/] [tcl/] [rutil/] [util.tcl] - Blame information for rev 33

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 32 wfjm 
# $Id: util.tcl 689 2015-06-05 14:33:18Z mueller $
2 10 wfjm 
#
3 30 wfjm 
# Copyright 2011-2015 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
4 10 wfjm 
#
5 
# This program is free software; you may redistribute and/or modify it under
6 
# the terms of the GNU General Public License as published by the Free
7 
# Software Foundation, either version 2, or at your option any later version.
8 
#
9 
# This program is distributed in the hope that it will be useful, but
10 
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
11 
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
12 
# for complete details.
13 
#
14 
#  Revision History:
15 
# Date         Rev Version  Comment
16 32 wfjm 
# 2015-06-05   688   1.0.5  add dohook
17 
# 2015-03-28   660   1.0.4  add com8 and com16
18 28 wfjm 
# 2014-12-23   619   1.0.3  regget: add check for unknown field descriptor
19 25 wfjm 
# 2014-07-12   569   1.0.2  add sxt16 and sxt32
20 21 wfjm 
# 2013-05-09   517   1.0.1  add optlist2arr
21 10 wfjm 
# 2011-03-27   374   1.0    Initial version
22 
# 2011-03-19   372   0.1    First draft
23 
#
24 
 
25 
package provide rutil 1.0
26 
 
27 
package require rutiltpp
28 
 
29 
namespace eval rutil {
30 
  #
31 25 wfjm 
  # optlist2arr: process options arguments given as key value list -----------
32 21 wfjm 
  #
33 
  proc optlist2arr {outarrname refarrname optlist} {
34 
    upvar $outarrname outarr
35 
    upvar $refarrname refarr
36 
    array set outarr [array get refarr]
37 
    foreach {key value} $optlist {
38 
      if {[info exists outarr($key)]} {
39 
        set outarr($key) $value
40 
      } else {
41 
        error "key $key not valid in optlist"
42 
      }
43 
    }
44 
    return ""
45 
  }
46 
 
47 
  #
48 25 wfjm 
  # regdsc: setup a register descriptor --------------------------------------
49 10 wfjm 
  #
50 
  proc regdsc {name args} {
51 
    upvar $name rdsc
52 
    set fbegmax -1
53 
    set mskftot 0
54 
 
55 
    foreach arg $args {
56 
      set nopt [llength $arg]
57 
      if {$nopt < 2} {
58 
        error "wrong number of elements in field dsc \"$arg\""
59 
      }
60 
      set fnam [lindex $arg 0]
61 
      set fbeg [lindex $arg 1]
62 
      set flen [lindex $arg 2]
63 
      if {$nopt < 3} { set flen 1 }
64 
      set popt [lindex $arg 3]
65 
      if {$nopt < 4} { set popt "b" }
66 
 
67 
      if {( $flen - 1 ) > $fbeg} {
68 
        error "error in field dsc \"$arg\": length > start position"
69 
      }
70 
 
71 21 wfjm 
      set mskb [expr {( 1 << $flen ) - 1}]
72 
      set mskf [expr {$mskb << ( $fbeg - ( $flen - 1 ) )}]
73 10 wfjm 
      set rdsc($fnam) [list $fbeg $flen $mskb $mskf $popt]
74 
 
75 
      if {$fbegmax < $fbeg} {set fbegmax $fbeg}
76 21 wfjm 
      set mskftot [expr {$mskftot | $mskf}]
77 10 wfjm 
    }
78 
 
79 
    set rdsc(-n) [lsort -decreasing -command regdsc_sort \
80 
                    [array names rdsc -regexp {^[^-]}] ]
81 
 
82 21 wfjm 
    set rdsc(-w) [expr {$fbegmax + 1}]
83 10 wfjm 
    set rdsc(-m) $mskftot
84 
 
85 
    return ""
86 
  }
87 
 
88 
  #
89 25 wfjm 
  # regdsc_print: print register descriptor ----------------------------------
90 10 wfjm 
  #
91 
  proc regdsc_print {name} {
92 
    upvar $name rdsc
93 
    set rval ""
94 
    if {! [info exists rdsc]} {
95 
      error "can't access \"$name\": variable doesn't exist"
96 
    }
97 
 
98 
    set rsize $rdsc(-w)
99 
 
100 
    append rval "     field   bits  bitmask"
101 
 
102 
    foreach fnam $rdsc(-n) {
103 
      set fdsc  $rdsc($fnam)
104 
      set fbeg  [lindex $fdsc 0]
105 
      set flen  [lindex $fdsc 1]
106 
      set fmskf [lindex $fdsc 3]
107 
      set line "  "
108 
      append line [format "%8s" $fnam]
109 
      if {$flen > 1} {
110 21 wfjm 
        append line [format "  %2d:%2d" $fbeg [expr {$fbeg - $flen + 1}]]
111 10 wfjm 
      } else {
112 
        append line [format "     %2d" $fbeg]
113 
      }
114 
      append line "  "
115 
      append line [pbvi "b${rsize}" $fmskf]
116 
      append rval "\n$line"
117 
    }
118 
    return $rval
119 
  }
120 
 
121 
  proc regdsc_sort {a b} {
122 
    upvar rdsc urdsc
123 21 wfjm 
    return [expr {[lindex $urdsc($a) 0] - [lindex $urdsc($b) 0] }]
124 10 wfjm 
  }
125 
 
126 
  #
127 25 wfjm 
  # regbld: build a register value from a list of fields ---------------------
128 10 wfjm 
  #
129 
  proc regbld {name args} {
130 
    upvar $name rdsc
131 
    set rval 0
132 
    foreach arg $args {
133 
      if {[llength $arg] < 1 || [llength $arg] > 2} {
134 
        error "error in field specifier \"$arg\": must be 'name [val]'"
135 
      }
136 
      set fnam [lindex $arg 0]
137 
      if {! [info exists rdsc($fnam)] } {
138 
        error "error in field specifier \"$arg\": field unknown"
139 
      }
140 
      set fbeg [lindex $rdsc($fnam) 0]
141 
      set flen [lindex $rdsc($fnam) 1]
142 
 
143 
      if {[llength $arg] == 1} {
144 
        if {$flen > 1} {
145 
          error "error in field specifier \"$arg\": no value and flen>1"
146 
        }
147 
        set mskf [lindex $rdsc($fnam) 3]
148 21 wfjm 
        set rval [expr {$rval | $mskf}]
149 10 wfjm 
 
150 
      } else {
151 
        set fval [lindex $arg 1]
152 
        set mskb [lindex $rdsc($fnam) 2]
153 
        if {$fval >= 0} {
154 
          if {$fval > $mskb} {
155 
            error "error in field specifier \"$arg\": value > $mskb"
156 
          }
157 
        } else {
158 21 wfjm 
          if {$fval < [expr {- $mskb}]} {
159 10 wfjm 
            error "error in field specifier \"$arg\": value < [expr -$mskb]"
160 
          }
161 21 wfjm 
          set fval [expr {$fval & $mskb}]
162 10 wfjm 
        }
163 21 wfjm 
        set rval [expr {$rval | $fval << ( $fbeg - ( $flen - 1 ) )}]
164 10 wfjm 
      }
165 
 
166 
    }
167 
    return $rval
168 
  }
169 
 
170 
  #
171 25 wfjm 
  # regget: extract field from a register value ------------------------------
172 10 wfjm 
  #
173 
  proc regget {name val} {
174 
    upvar $name fdsc
175 28 wfjm 
    if {! [info exists fdsc] } {
176 
      error "register field descriptor \"$name\" unknown"
177 
    }
178 10 wfjm 
    set fbeg [lindex $fdsc 0]
179 
    set flen [lindex $fdsc 1]
180 
    set mskb [lindex $fdsc 2]
181 21 wfjm 
    return [expr {( $val >> ( $fbeg - ( $flen - 1 ) ) ) & $mskb}]
182 10 wfjm 
  }
183 
 
184 
  #
185 25 wfjm 
  # regtxt: convert register value to a text string --------------------------
186 10 wfjm 
  #
187 
  proc regtxt {name val} {
188 
    upvar $name rdsc
189 
    set rval ""
190 
 
191 
    foreach fnam $rdsc(-n) {
192 
      set popt [lindex $rdsc($fnam) 4]
193 
      set fval [regget rdsc($fnam) $val]
194 
      if {$popt ne "-"} {
195 
        if {$rval ne ""} {append rval " "}
196 
        append rval "${fnam}:"
197 
        if {$popt eq "b"} {
198 
          set flen [lindex $rdsc($fnam) 1]
199 
          append rval [pbvi b${flen} $fval]
200 
        } else {
201 
          append rval [format "%${popt}" $fval]
202 
        }
203 
      }
204 
    }
205 
    return $rval
206 
  }
207 30 wfjm 
 
208 10 wfjm 
  #
209 25 wfjm 
  # errcnt2txt: returns "PASS" if 0 and "FAIL" otherwise ---------------------
210 10 wfjm 
  #
211 
  proc errcnt2txt {errcnt} {
212 
    if {$errcnt} {return "FAIL"}
213 
    return "PASS"
214 
  }
215 30 wfjm 
 
216 25 wfjm 
  #
217 
  # sxt16: 16 bit sign extend ------------------------------------------------
218 
  #
219 
  proc sxt16 {val} {
220 
    if {$val & 0x8000} {                    # bit 15 set ?
221 
      set val [expr $val | ~ 077777];       # --> set bits 15 and higher
222 
    }
223 
    return $val
224 
  }
225 10 wfjm 
 
226 25 wfjm 
  #
227 
  # sxt32: 32 bit sign extend ------------------------------------------------
228 
  #
229 
  proc sxt32 {val} {
230 
    if {$val & 0x80000000} {                # bit 31 set ?
231 
      set val [expr $val | ~ 017777777777]; # --> set bits 31 and higher
232 
    }
233 
    return $val
234 
  }
235 
 
236 
  #
237 30 wfjm 
  # com8: 8 bit complement ---------------------------------------------------
238 
  #
239 
  proc com8 {val} {
240 
    return [expr (~$val) & 0xff]
241 
  }
242 
 
243 
  #
244 32 wfjm 
  # com16: 16 bit complement -------------------------------------------------
245 30 wfjm 
  #
246 
  proc com16 {val} {
247 
    return [expr (~$val) & 0xffff]
248 
  }
249 
 
250 
  #
251 32 wfjm 
  # dohook: source a hook script if is defined -------------------------------
252 
  #
253 
  proc dohook {name} {
254 
    set fname "${name}.tcl"
255 
    if {[file readable $fname]} {
256 
      puts "dohook: $fname"
257 
      source $fname
258 
    }
259 
    return
260 
  }
261 
 
262 
  #
263 25 wfjm 
  # ! export reg... procs to global scope ------------------------------------
264 
  #
265 
 
266 10 wfjm 
  namespace export regdsc
267 
  namespace export regdsc_print
268 
  namespace export regbld
269 
  namespace export regget
270 
  namespace export regtxt
271 
}
272 
 
273 
namespace import rutil::regdsc
274 
namespace import rutil::regdsc_print
275 
namespace import rutil::regbld
276 
namespace import rutil::regget
277 
namespace import rutil::regtxt

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.