Ignore:
Timestamp:
04/01/09 02:51:29 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

    r13998 r14025  
    135135}
    136136
    137 #if 0 /* Unused */
    138 static const unsigned char
    139 BitReverseTable256[] = {
    140   0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0, 0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0,
    141   0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8, 0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8,
    142   0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4, 0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4,
    143   0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC, 0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC,
    144   0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2, 0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2,
    145   0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA, 0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA,
    146   0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6, 0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6,
    147   0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE, 0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE,
    148   0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1, 0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1,
    149   0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9, 0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9,
    150   0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5, 0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5,
    151   0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED, 0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD,
    152   0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3, 0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3,
    153   0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB, 0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB,
    154   0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7, 0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7,
    155   0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF, 0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF};
    156 
    157 #define REVERSE_BYTE( b )   BitReverseTable256[ (b) ]
    158 
    159 #define REVERSE_LOW_BITS( b, w ) \
    160     ((CHAR_BIT == (w)) \
    161         ? REVERSE_BYTE( b ) \
    162         : (HIGH_BITS( REVERSE_BYTE( LOW_BITS( (b), (w) ) ), (w) ) >> (w)))
    163 
    164 #define REVERSE_BITS( b, s, e ) \
    165     ((0 == (s)) \
    166         ? REVERSE_LOW_BITS( (b), (e) ) \
    167         : (REVERSE_LOW_BITS( ((b) >> (e)), ((e) - (s)) ) << (e)))
    168 #endif
    169 
    170 #if 0 /* Doesn't work */
    171137static C_uword
    172 C_uword_bits_reverse( C_uword n, C_uword s, C_uword e)
     138C_uword_rotate_bit_field( C_uword n, unsigned int s, unsigned int e, unsigned int c )
    173139{
    174   #define FULBYT( n )   ((n) / CHAR_BIT)
    175   #define REMBYT( n )   (0 == ((n) % CHAR_BIT) ? 0 : 1)
    176   #define TOTBYT( n )   (FULBYT( n ) + REMBYT( n ))
    177   #ifdef C_BIG_ENDIAN
    178   # define BYTPTR( n, p )   (((uint8_t *) &n) + (sizeof( C_uword ) - FULBYT( p )))
    179   #else
    180   # define BYTPTR( n, p )   (((uint8_t *) &n) + FULBYT( e ))
    181   #endif
    182 
    183   #ifdef C_SIXTY_FOUR
    184   #else
    185   #endif
    186 
    187   C_uword wid = e - s;
    188 
    189   C_uword SS = s % CHAR_BIT;
    190   C_uword EE = e % CHAR_BIT;
    191   C_word FUL = (C_word) wid - (SS * CHAR_BIT) - (EE * CHAR_BIT);
    192 
    193   C_uword SE = MIN( CHAR_BIT, EE );
    194   C_uword ES = MAX( 0, FUL );
    195 
    196   uint8_t *srt = BYTPTR( n, e );
    197   uint8_t *end = BYTPTR( n, s );
    198 
    199   for ( ; end > srt; ++srt, --end) {
    200     C_uword tmp = REVERSE_BYTE( *srt );
    201     *srt = REVERSE_BYTE( *end );
    202     *end = temp;
     140  if (0 != n) {
     141    unsigned int wid = e - s;
     142    unsigned int cnt = c % wid;
     143    C_uword fld = BITS( n, s, e );
     144    return BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) );
    203145  }
    204146
    205   *srt = REVERSE_BITS( *srt, s % CHAR_BIT, e % CHAR_BIT );
    206   *end = REVERSE_BITS( *end, s % CHAR_BIT, e % CHAR_BIT );
     147  return 0;
    207148}
    208 #endif
    209149
    210150static C_uword
    211 C_word_bits_bit_count( C_word n )
     151C_uword_reverse( C_uword n, int c )
    212152{
    213   C_return( (0 < n)
    214               ? C_uword_bits( (C_uword) n )
    215               : ((0 == n) ? 0 : /*~*/ C_uword_bits( (C_uword) ~n )) );
     153  int isneg = ((C_word) n) < 0;
     154  unsigned int mask = isneg ? ~((C_word) n) : n;
     155  C_uword revval = 0;
     156  for (--c; 0 <= c; --c, mask >>= 1) {
     157    revval = (revval << 1) | (1 & mask) ;
     158  }
     159  return isneg ? ~revval : revval;
    216160}
    217161
    218 #if 0 /* Doesn't work */
    219162static C_uword
    220 C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
     163C_uword_reverse_bit_field( C_uword n, unsigned int s, unsigned int e )
    221164{
    222   #define ASH( n , s )  ((0 < (s)) ? ((n) << (s)) : ((n) >> -(s)))
    223 
    224   C_uword wid = e - s;
    225 
    226   if (0 == wid) C_return( n );
    227   else {
    228     C_word cnt = c % wid;
    229     C_uword msk = LOW_MASK( wid );
    230     C_uword fld = BITS( n, s, e );
    231 
    232     C_return( ((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << s) | (n & ~ (msk << s)) );
    233   }
    234 
    235   #undef ASH
     165  unsigned int width = e - s;
     166  C_uword mask = ~(((C_uword) -1) << width);
     167  return (C_uword_reverse( (mask & (n >> s)), width ) << s) | (~(mask << s) & n);
    236168}
    237 #else
    238 static C_uword
    239 C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
    240 {
    241   if (0 == n) C_return( n );
    242   else {
    243     C_uword wid = e - s;
    244     C_uword cnt = c % wid;
    245     C_uword fld = BITS( n, s, e );
    246 
    247     #if 0
    248     C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
    249     #else
    250     C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
    251     #endif
    252   }
    253 }
    254 #endif
    255169<#
    256170
     
    315229      (%boolean->bit obj) ) )
    316230
     231;; Fold operations
     232
     233;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
     234
     235(define-inline (%bwfold loc func init ls)
     236  (%check-integer loc init)
     237  (let loop ((ls ls) (acc init))
     238    (if (%null? ls) acc
     239        (let ((cur (%car ls)))
     240          (%check-integer loc cur)
     241          (loop (%cdr ls) (func acc cur)) ) ) ) )
     242
    317243;;;
    318244
    319245(module err5rs-arithmetic-bitwise (;export
    320   ; ERR5RS
    321   ;;bitwise-and bitwise-ior bitwise-xor bitwise-not - from chicken
     246  ;; ERR5RS
     247  bitwise-and bitwise-ior bitwise-xor bitwise-not
    322248  bitwise-if
    323249  bitwise-test?
     
    334260  bitwise-list->integer bitwise-integer->list
    335261  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
    336   ; Extras
     262  ;; Chicken Originals
     263  chicken:bitwise-not chicken:bitwise-and chicken:bitwise-ior chicken:bitwise-xor
     264  ;; Extras
    337265  pow2log2
    338266  bitwise-last-bit-set
    339267  bitwise-if-not
    340268  boolean->bit
     269  *bitwise-and *bitwise-ior *bitwise-xor *bitwise-not
    341270  *bitwise-if
    342271  *bitwise-test?
     
    357286  *pow2log2)
    358287
    359 (import scheme chicken foreign srfi-1 int-limits)
     288(import scheme
     289        (rename chicken
     290          (bitwise-and chicken:bitwise-and)
     291          (bitwise-ior chicken:bitwise-ior)
     292          (bitwise-xor chicken:bitwise-xor)
     293          (bitwise-not chicken:bitwise-not))
     294        foreign srfi-1 int-limits)
    360295
    361296(require-library srfi-1 int-limits)
     
    389324;; ERR5RS
    390325
     326(define *bitwise-not
     327  (foreign-lambda* integer ((unsigned-integer n))
     328   "return( ~n );"))
     329
     330(define *bitwise-and
     331  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
     332   "return( n & m );"))
     333
     334(define *bitwise-ior
     335  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
     336   "return( n | m );"))
     337
     338(define *bitwise-xor
     339  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
     340   "return( n ^ m );"))
     341
    391342(define *bitwise-if
    392   (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
    393    "C_return( BITS_MERGE( m, t, f ) );"))
     343  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
     344   "return( BITS_MERGE( m, t, f ) );"))
    394345
    395346(define *bitwise-test?
    396   (foreign-lambda* bool ((integer a) (integer b))
    397    "C_return( BITS_TEST( a, b ) );"))
     347  (foreign-lambda* bool ((unsigned-integer a) (unsigned-integer b))
     348   "return( BITS_TEST( a, b ) );"))
    398349
    399350(define *bitwise-bit-count
    400   (foreign-lambda unsigned-int "C_word_bits_bit_count" integer))
     351  (foreign-lambda unsigned-int "C_uword_bits" unsigned-integer))
    401352
    402353(define *bitwise-length
    403   (foreign-lambda* unsigned-int ((integer n))
    404    "C_return( C_uword_log2( (C_uword) ((n < 0) ? ~ n : n ) ) );"))
     354  (foreign-lambda* unsigned-int ((unsigned-integer n))
     355   "return( C_uword_log2( ((C_word) n) < 0 ? ~n : n ) );"))
    405356
    406357(define *bitwise-first-bit-set
    407   (foreign-lambda* int ((integer n))
    408    "C_return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );"))
     358  (foreign-lambda* int ((unsigned-integer n))
     359   "return( C_UWORD_LOG2_FACTORS( n ) );"))
    409360
    410361(define *bitwise-bit-set?
    411   (foreign-lambda* bool ((integer n) (unsigned-int i))
    412    "C_return( BIT_TEST( n, i ) );"))
     362  (foreign-lambda* bool ((unsigned-integer n) (unsigned-int i))
     363   "return( BIT_TEST( n, i ) );"))
    413364
    414365(define *bitwise-copy-bit
    415   (foreign-lambda* integer ((integer to) (unsigned-int i) (unsigned-int b))
    416    "C_return( BIT_COPY( to, i, b ) );"))
     366  (foreign-lambda* integer ((unsigned-integer to) (unsigned-int i) (unsigned-int b))
     367   "return( BIT_COPY( to, i, b ) );"))
    417368
    418369(define *bitwise-bit-field
    419   (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e))
    420    "C_return( BITS( n, s, e ) );"))
     370  (foreign-lambda* integer ((unsigned-integer n) (unsigned-int s) (unsigned-int e))
     371   "return( BITS( n, s, e ) );"))
    421372
    422373(define *bitwise-copy-bit-field
    423   (foreign-lambda* integer ((integer t) (unsigned-int s) (unsigned-int e) (integer f))
    424    "C_return( BITS_COPY( t, s, e, f ) );"))
     374  (foreign-lambda* integer ((unsigned-integer t) (unsigned-int s) (unsigned-int e) (unsigned-integer f))
     375   "return( BITS_COPY( t, s, e, f ) );"))
    425376
    426377(define *bitwise-rotate-bit-field
    427   (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e) (unsigned-int c))
    428    "C_return( C_uword_bits_rotate_bit_field( (C_uword) n, s, e, c ) );"))
    429 
     378  (foreign-lambda integer "C_uword_rotate_bit_field" unsigned-integer unsigned-int unsigned-int unsigned-int))
     379
     380(define *bitwise-reverse
     381  (foreign-lambda integer "C_uword_reverse" unsigned-integer unsigned-int))
     382
     383#;
    430384(define (*bitwise-reverse n c)
    431385  (let ((negval? (%negative? n)))
     
    435389        ((%fxnegative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
    436390
    437 #; ;DOESN'T WORK
    438391(define *bitwise-reverse-bit-field
    439   (foreign-lambda integer "C_uword_bits_reverse" integer unsigned-int unsigned-int))
    440 
     392  (foreign-lambda integer "C_uword_reverse_bit_field" unsigned-integer unsigned-int unsigned-int))
     393
     394#;
    441395(define (*bitwise-reverse-bit-field n s e)
    442396  (let* ((width (%fx- e s))
     
    448402
    449403; returns (list lsb .. msb)
    450 (define (*bitwise-list->integer lyst)
    451   (let loop ((ls lyst) (i 0) (n 0))
     404(define (*bitwise-list->integer ls)
     405  (let loop ((ls ls) (i 0) (n 0))
    452406    (if (%null? ls) n
    453         (loop (%cdr ls) (%fx+ i 1) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
     407        (loop (%cdr ls) (%fxadd1 i) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
    454408
    455409; returns (list lsb .. msb)
     
    457411  (let ((zeros (make-list machine-word-bits #f)))
    458412    (lambda (n #!optional bitlen)
    459       (if (%zero? n)
    460           (if bitlen (take zeros bitlen) zeros)
     413      (if (%zero? n) (if bitlen (take zeros bitlen) zeros)
    461414          (let ((bitlen (or bitlen (*bitwise-length n))))
    462415            (let loop ((i 0) (ils '()))
     
    464417                  (loop (%fxadd1 i) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
    465418
    466 (define (*bitwise-arithmetic-shift value signed-count)
    467   (%arithmetic-shift value signed-count) )
    468 
    469 (define (*bitwise-arithmetic-shift-left value count)
    470   (%arithmetic-shift value count) )
    471 
    472 (define (*bitwise-arithmetic-shift-right value count)
    473    (%arithmetic-shift value (%fxneg count)) )
     419(define (*bitwise-arithmetic-shift value signed-count) (%arithmetic-shift value signed-count))
     420
     421(define (*bitwise-arithmetic-shift-left value count) (%arithmetic-shift value count))
     422
     423(define (*bitwise-arithmetic-shift-right value count) (%arithmetic-shift value (%fxneg count)))
    474424
    475425;; Extras
    476426
    477427(define *bitwise-if-not
    478   (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
    479    "C_return( BITS_MERGE_NOT( m, t, f ) );"))
     428  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
     429   "return( BITS_MERGE_NOT( m, t, f ) );"))
    480430
    481431(define *bitwise-last-bit-set
    482   (foreign-lambda* unsigned-int ((integer n))
    483    "C_return( C_uword_log2( (C_uword) n ) );"))
     432  (foreign-lambda* unsigned-int ((unsigned-integer n))
     433   "return( C_uword_log2( n ) - 1);"))
    484434
    485435(define *pow2log2
    486   (foreign-lambda* unsigned-int ((integer n))
    487    "C_return( 2 << C_uword_log2( (C_uword) n ) );"))
     436  (foreign-lambda* unsigned-int ((unsigned-integer n))
     437   "return( 2 << C_uword_log2( n ) );"))
    488438
    489439;;; ERR5RS
     440
     441(define (bitwise-not value)
     442  (%check-integer 'bitwise-not value)
     443  (*bitwise-not value) )
     444
     445(define (bitwise-and value . values)
     446  (%bwfold 'bitwise-and *bitwise-and value values) )
     447
     448(define (bitwise-ior value . values)
     449  (%bwfold 'bitwise-ior *bitwise-ior value values) )
     450
     451(define (bitwise-xor value . values)
     452  (%bwfold 'bitwise-xor *bitwise-xor value values) )
    490453
    491454(define (bitwise-if mask true false)
     
    551514  (*bitwise-reverse-bit-field value start end) )
    552515
    553 (define (bitwise-list->integer lyst)
    554   (%check-list 'bitwise-list->integer lyst)
    555   (*bitwise-list->integer lyst) )
     516(define (bitwise-list->integer bits)
     517  (%check-list 'bitwise-list->integer bits)
     518  (*bitwise-list->integer bits) )
    556519
    557520(define (bitwise-integer->list value #!optional bitlen)
Note: See TracChangeset for help on using the changeset viewer.