\ Rewritten and improved bitmask code
\ Author: David Kühling <dvdkhlng AT gmx DOT de>
\ Created: May 2010
\ Copyright (C) 2010 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, 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 more details.
\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.
: bitset? ( x #bit -- flag ) \ get value of single bit in cell x
rshift 1 and ;
: setbit ( x1 0|1 #bit -- x2 ) \ set value of single bit in cell x
1 over lshift invert -rot \ mask for deleting bit
lshift \ mask for optionally setting bit
-rot and or ; \ first delete then optionally set bit
: (bits/cell) ( -- +n ) \ measure number of bits per cell
1 1 begin 1 lshift dup while
swap 1+ swap
repeat drop ;
(bits/cell) CONSTANT bits/cell
: dispense ( x1-val x2-mask -- x3-masked )
\ encode val into the bits given by mask. bits in mask can be spread out
\ as much as you like. for signed values 'val', first apply 'narrow' below
bits/cell 0 do \ iterate over bits in mask
dup i bitset? if \ if mask bit set:
over 1 and i setbit \ replace bit in mask by val's bit
swap 1 rshift swap \ and remove bit from val
then
loop
swap 0<> ABORT" dispense: value does not fit into masked bits" ;
: embed ( x2-val x1-accu x3-mask -- x4-result )
\ encode 'val' into bits given by mask, replacing these bits in 'accu'
tuck invert and -rot \ delete corresponding bits in accu
dispense or ; \ dispense value over masked bits, onto accu ;
: mask ( +n -- mask ) \ get bitmask for lowest #n bits
0 invert swap lshift invert ;
: narrow ( n1 n2 -- x ) \ limit signed value to n2 bits
\ note: assumes 2-complement number n1 and 2-complement host
2dup mask and -rot \ compute masked value,
1- \ but before returning, check whether no bits lost
-1 over lshift ( lower bund)
1 rot lshift ( upper bound)
within 0= ABORT" narrow: signed value out of range" ;
: maskinto ( "x-mask" -- runtime: x1-val x1-accu -- x2-masked )
\ for backwards compatability with old bitmask code
parse-word s>number drop ]]L embed [[ ; IMMEDIATE
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>