Changeset 38599 in project for release


Ignore:
Timestamp:
04/08/20 18:38:26 (4 months ago)
Author:
Kon Lovett
Message:

add srfi-60 inspired routines

Location:
release/5/bitwise-utils/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/bitwise-utils/trunk/bitwise-utils.egg

    r38593 r38599  
    33
    44((synopsis "Bitwise utilities")
    5  (version "1.0.1")
     5 (version "1.1.0")
    66 (category data)
    77 (author "[[kon lovett]]")
  • release/5/bitwise-utils/trunk/bitwise-utils.scm

    r38593 r38599  
    11;;;; bitwise-utils.scm  -*- Scheme -*-
    22;;;; Kon Lovett, Apr '20
     3
     4;portions
     5
     6;;;; "logical.scm", bit access and operations for integers for Scheme
     7;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
     8;
     9;Permission to copy this software, to modify it, to redistribute it,
     10;to distribute modified versions, and to use it for any purpose is
     11;granted, subject to the following restrictions and understandings.
     12;
     13;1.  Any copy made of this software must include this copyright notice
     14;in full.
     15;
     16;2.  I have made no warranty or representation that the operation of
     17;this software will be error-free, and I am under no obligation to
     18;provide any services, by way of maintenance, update, or otherwise.
     19;
     20;3.  In conjunction with products arising from the use of this
     21;material, there shall be no use of my name in any advertising,
     22;promotional, or sales literature without prior written consent in
     23;each case.
    324
    425;;;; Issues
     
    4162  bitwise-join
    4263  bitwise-split
    43   bitwise-count)
     64  bitwise-count
     65  bitwise-merge
     66  bitwise-nth?
     67  bitwise-any?
     68  bitwise-first-set
     69  bitwise-reverse
     70  bitwise-set-nth
     71  bitwise-field bitwise-field-copy bitwise-field-reverse bitwise-field-rotate
     72  integer->list list->integer)
     73
    4474
    4575(import scheme)
    46 (import (only (chicken base) fixnum? foldl cut))
     76(import (only (chicken base) sub1 add1 fixnum? foldl cut))
    4777(import (chicken type))
    4878(import (chicken foreign))
    4979(import (only (chicken bitwise)
    50   integer-length arithmetic-shift
     80  integer-length arithmetic-shift bit->boolean
    5181  bitwise-not bitwise-and bitwise-ior))
    5282
     
    6191(: bitwise-split (integer fixnum --> (list-of integer)))
    6292(: bitwise-count (integer --> fixnum))
     93(: bitwise-merge (integer integer integer --> integer))
     94(: bitwise-nth? (integer fixnum --> boolean))
     95(: bitwise-any? (integer integer --> boolean))
     96(: bitwise-first-set (integer --> fixnum))
     97(: bitwise-reverse (integer fixnum --> integer))
     98(: bitwise-rotate (integer fixnum fixnum --> integer))
     99(: bitwise-set-nth (integer fixnum boolean --> integer))
     100(: bitwise-field (integer fixnum fixnum --> integer))
     101(: bitwise-field-copy (integer integer fixnum fixnum --> integer))
     102(: bitwise-field-reverse (integer fixnum fixnum --> integer))
     103(: bitwise-field-rotate (integer fixnum fixnum fixnum --> integer))
     104(: integer->list (integer #!optional boolean --> (list-of fixnum)))
     105(: list->integer (list --> integer))
    63106
    64107;observes sign - does sign extend
     
    99142          (loop (*logical-shift-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) )
    100143
     144(define (bitwise-abs n) (if (negative? n) (bitwise-not n) n))
     145
    101146(define *uword-size* (foreign-type-size "C_uword"))
    102147
     
    112157
    113158(define (bitwise-count n)
    114   (if (fixnum? n) (uword-bitwise-count n)
    115     (foldl
    116       (lambda (c i) (+ c (uword-bitwise-count i)))
    117       0
    118       (bitwise-split n (* 8 *uword-size*))) ) )
     159  (let ((n (bitwise-abs n)))
     160    (if (fixnum? n) (uword-bitwise-count n)
     161      (foldl
     162        (lambda (c i) (+ c (uword-bitwise-count i)))
     163        0
     164        (bitwise-split n (* 8 *uword-size*))) ) ) )
     165
     166(define (bitwise-merge mask n0 n1)
     167  (bitwise-ior
     168    (bitwise-and mask n0)
     169    (bitwise-and (bitwise-not mask) n1)) )
     170
     171(define (bitwise-nth? index n)
     172  (bit->boolean n index) )
     173
     174(define (bitwise-any? n1 n2)
     175  (not (zero? (bitwise-and n1 n2))) )
     176
     177(define (bitwise-first-set n)
     178  (sub1 (integer-length (bitwise-and n (- n)))) )
     179
     180(define (bitwise-reverse n k)
     181  (do ((m (bitwise-abs n) (arithmetic-shift m -1))
     182       (k (sub1 k) (sub1 k))
     183       (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))))
     184      ((negative? k) (if (negative? n) (bitwise-not rvs) rvs))))
     185
     186(define (bitwise-rotate k count len)
     187  (bitwise-field-rotate k count 0 len) )
     188
     189(define (bitwise-set-nth to index bool)
     190  (if bool
     191    (bitwise-ior to (arithmetic-shift 1 index))
     192    (bitwise-and to (bitwise-not (arithmetic-shift 1 index))) ) )
     193
     194(define (bitwise-field n start end)
     195  (bitwise-and
     196    (bitwise-not (arithmetic-shift -1 (- end start)))
     197          (arithmetic-shift-right n start)) )
     198
     199(define (bitwise-field-copy to from start end)
     200  (bitwise-merge
     201    (arithmetic-shift (bitwise-not (arithmetic-shift -1 (- end start))) start)
     202    (arithmetic-shift from start)
     203    to) )
     204
     205(define (bitwise-field-reverse n start end)
     206  (let* (
     207    (width (- end start))
     208    (mask (bitwise-mask width))
     209    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
     210    (bitwise-ior
     211      (arithmetic-shift (bitwise-reverse zn width) start)
     212            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
     213
     214(define (bitwise-field-rotate n count start end)
     215  (let* (
     216    (width (- end start))
     217    (count (modulo count width))
     218    (mask (bitwise-mask width))
     219    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
     220    (bitwise-ior
     221      (arithmetic-shift
     222        (bitwise-ior
     223          (bitwise-and mask (arithmetic-shift zn count))
     224          (arithmetic-shift zn (- count width)))
     225        start)
     226            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
     227
     228(define (integer->list k #!optional len)
     229  (if (not len)
     230    (do ((k k (arithmetic-shift k -1))
     231         (lst '() (cons (add1 k) lst)) )
     232        ((<= k 0) lst))
     233    (do ((idx (sub1 len) (sub1 idx))
     234         (k k (arithmetic-shift k -1))
     235         (lst '() (cons (add1 k) lst)))
     236        ((negative? idx) lst)) ) )
     237
     238(define (list->integer bools)
     239  (do ((bs bools (cdr bs))
     240       (acc 0 (+ acc acc (if (car bs) 1 0))))
     241      ((null? bs) acc)) )
    119242
    120243) ;bitwise-utils
  • release/5/bitwise-utils/trunk/tests/bitwise-utils-test.scm

    r38593 r38599  
    5858
    5959(test 29 (bitwise-count #xb0000000000000000000000000110000deadbeef))
    60 (test 73 (bitwise-count #x-b0000000000000000000000000110000deadbeef))
     60(test 28 (bitwise-count #x-b0000000000000000000000000110000deadbeef))
    6161
    6262;;;
Note: See TracChangeset for help on using the changeset viewer.