home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / bitstr.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  111 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: bitstr.scm,v 14.3 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Bit String Primitives
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-primitives
  28.  bit-string-allocate make-bit-string bit-string?
  29.  bit-string-length bit-string-ref bit-string-clear! bit-string-set!
  30.  bit-string-zero? bit-string=?
  31.  bit-string-fill! bit-string-move! bit-string-movec!
  32.  bit-string-or! bit-string-and! bit-string-andc!
  33.  bit-string-xor! bit-substring-move-right!
  34.  bit-string->unsigned-integer unsigned-integer->bit-string
  35.  read-bits! write-bits!
  36.  bit-substring-find-next-set-bit)
  37.  
  38. (define (bit-string-copy bit-string)
  39.   (let ((result (bit-string-allocate (bit-string-length bit-string))))
  40.     (bit-string-move! result bit-string)
  41.     result))
  42.  
  43. (define (bit-string-not bit-string)
  44.   (let ((result (bit-string-allocate (bit-string-length bit-string))))
  45.     (bit-string-movec! result bit-string)
  46.     result))
  47.  
  48. (define (bit-string-or x y)
  49.   (let ((result (bit-string-allocate (bit-string-length x))))
  50.     (bit-string-move! result x)
  51.     (bit-string-or! result y)
  52.     result))
  53.  
  54. (define (bit-string-and x y)
  55.   (let ((result (bit-string-allocate (bit-string-length x))))
  56.     (bit-string-move! result x)
  57.     (bit-string-and! result y)
  58.     result))
  59.  
  60. (define (bit-string-andc x y)
  61.   (let ((result (bit-string-allocate (bit-string-length x))))
  62.     (bit-string-move! result x)
  63.     (bit-string-andc! result y)
  64.     result))
  65.  
  66. (define (bit-string-xor x y)
  67.   (let ((result (bit-string-allocate (bit-string-length x))))
  68.     (bit-string-move! result x)
  69.     (bit-string-xor! result y)
  70.     result))
  71.  
  72. (define (bit-substring bit-string start end)
  73.   (let ((result (bit-string-allocate (- end start))))
  74.     (bit-substring-move-right! bit-string start end result 0)
  75.     result))
  76.  
  77. (define (bit-substring-extend string start end length)
  78.   ;; Assumption: (<= (- end start) length)
  79.   (let ((result (make-bit-string length false)))
  80.     (bit-substring-move-right! string start end result 0)
  81.     result))
  82.  
  83. (define (bit-string-append x y)
  84.   (declare (integrate x y))
  85.   (let ((x-length (bit-string-length x))
  86.     (y-length (bit-string-length y)))
  87.     (let ((result (bit-string-allocate (+ x-length y-length))))
  88.       (bit-substring-move-right! x 0 x-length result 0)
  89.       (bit-substring-move-right! y 0 y-length result x-length)
  90.       result)))
  91.  
  92. (define (bit-string-append-reversed x y)
  93.   (declare (integrate bit-string-append))
  94.   (bit-string-append y x))
  95.  
  96. (define (signed-integer->bit-string nbits number)
  97.   (unsigned-integer->bit-string
  98.    nbits
  99.    (cond ((negative? number)
  100.       (if (>= number (- (expt 2 (-1+ nbits))))
  101.           (+ number (expt 2 nbits))
  102.           (error "Integer too small to be encoded" number)))
  103.      ((< number (expt 2 (-1+ nbits))) number)
  104.      (else (error "Integer too large to be encoded" number)))))
  105.  
  106. (define (bit-string->signed-integer bit-string)
  107.   (let ((unsigned-result (bit-string->unsigned-integer bit-string))
  108.     (nbits (bit-string-length bit-string)))
  109.     (if (bit-string-ref bit-string (-1+ nbits))    ;Sign bit.
  110.     (- unsigned-result (expt 2 nbits))
  111.     unsigned-result)))