1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
;;; -*-Scheme-*-
;;;
;;; The Scheme layer of the bitstring extension.
(require 'bitstring.la)
(define (bitstring-copy b)
(let ((new (make-bitstring (bitstring-length b) #f)))
(bitstring-move! new b)
new))
(define (bitstring-append a b)
(let* ((alen (bitstring-length a))
(blen (bitstring-length b))
(new (make-bitstring (+ alen blen) #f)))
(bitstring-substring-move! a 0 alen new 0)
(bitstring-substring-move! b 0 blen new alen)
new))
(define (bitstring-substring b from to)
(let ((new (make-bitstring (- to from) #f)))
(bitstring-substring-move! b from to new 0)
new))
(define (bitstring-not b)
(let ((new (bitstring-copy b)))
(bitstring-not! new b)
new))
(define (bitstring-make-logical-function fun!)
(lambda (a b)
(let ((new (bitstring-copy a)))
(fun! new b)
new)))
(define bitstring-and (bitstring-make-logical-function bitstring-and!))
(define bitstring-andnot (bitstring-make-logical-function bitstring-andnot!))
(define bitstring-or (bitstring-make-logical-function bitstring-or!))
(define bitstring-xor (bitstring-make-logical-function bitstring-xor!))
(define (signed-integer->bitstring len n)
(if (or (>= n (expt 2 (1- len))) (< n (- (expt 2 (1- len)))))
(error 'signed-integer->bitstring
"length ~s too small for signed integer ~s" len n))
(unsigned-integer->bitstring len (if (negative? n) (+ n (expt 2 len)) n)))
(define (bitstring->signed-integer b)
(let ((n (bitstring->unsigned-integer b))
(len (bitstring-length b)))
(cond ((zero? len) 0)
((bitstring-ref b (1- len)) (- n (expt 2 len)))
(else n))))
(define (describe-bitstring b)
(let ((len (bitstring-length b)))
(format #t "a bitstring of length ~s bit~a.~%" len
(if (= len 1) "" "s"))))
(provide 'bitstring)
|
