mirror of
https://github.com/wfjm/w11.git
synced 2026-02-02 07:01:38 +00:00
112 lines
3.0 KiB
Tcl
112 lines
3.0 KiB
Tcl
# $Id: util.tcl 985 2018-01-03 08:59:40Z mueller $
|
|
#
|
|
# Copyright 2011-2015 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 3, 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
|
|
# 2015-07-25 704 1.1.1 rename optlist2arr->args2opts, new logic, export it
|
|
# 2015-06-26 695 1.1 move reg* proc to regdsc.tcl
|
|
# 2015-06-05 688 1.0.5 add dohook
|
|
# 2015-03-28 660 1.0.4 add com8 and com16
|
|
# 2014-12-23 619 1.0.3 regget: add check for unknown field descriptor
|
|
# 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 {
|
|
#
|
|
# args2opts: process options arguments given as key value list -----------
|
|
#
|
|
proc args2opts {optsName refs args} {
|
|
upvar $optsName opts
|
|
if {[llength $args] % 2 != 0} {
|
|
error "args2opts-E: odd number of optional key value args"
|
|
}
|
|
array set opts $refs
|
|
foreach {key value} $args {
|
|
if {[info exists opts($key)]} {
|
|
set opts($key) $value
|
|
} else {
|
|
error "args2opts-E: key $key not valid in optlist"
|
|
}
|
|
}
|
|
return
|
|
}
|
|
|
|
#
|
|
# 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
|
|
}
|
|
|
|
#
|
|
# com8: 8 bit complement ---------------------------------------------------
|
|
#
|
|
proc com8 {val} {
|
|
return [expr (~$val) & 0xff]
|
|
}
|
|
|
|
#
|
|
# com16: 16 bit complement -------------------------------------------------
|
|
#
|
|
proc com16 {val} {
|
|
return [expr (~$val) & 0xffff]
|
|
}
|
|
|
|
#
|
|
# dohook: source a hook script if is defined -------------------------------
|
|
#
|
|
proc dohook {name} {
|
|
set fname "${name}.tcl"
|
|
if {[file readable $fname]} {
|
|
puts "dohook: $fname"
|
|
source $fname
|
|
}
|
|
return
|
|
}
|
|
|
|
# ! export some procs to global scope --------------------------------------
|
|
|
|
namespace export args2opts
|
|
|
|
}
|
|
|
|
namespace import rutil::args2opts
|