home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / logical.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  5.3 KB  |  169 lines
  1. ;;;; "logical.scm", bit access and operations for integers for Scheme
  2. ;;; Copyright (C) 1991, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define logical:integer-expt
  21.   (if (provided? 'inexact)
  22.       expt
  23.       (lambda (n k)
  24.     (logical:ipow-by-squaring n k 1 *))))
  25.  
  26. (define (logical:ipow-by-squaring x k acc proc)
  27.   (cond ((zero? k) acc)
  28.     ((= 1 k) (proc acc x))
  29.     (else (logical:ipow-by-squaring (proc x x)
  30.                     (quotient k 2)
  31.                     (if (even? k) acc (proc acc x))
  32.                     proc))))
  33.  
  34. (define (logical:logand n1 n2)
  35.   (cond ((= n1 n2) n1)
  36.     ((zero? n1) 0)
  37.     ((zero? n2) 0)
  38.     (else
  39.      (+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16)
  40.         (vector-ref (vector-ref logical:boole-and (modulo n1 16))
  41.             (modulo n2 16))))))
  42.  
  43. (define (logical:logior n1 n2)
  44.   (cond ((= n1 n2) n1)
  45.     ((zero? n1) n2)
  46.     ((zero? n2) n1)
  47.     (else
  48.      (+ (* (logical:logior (logical:ash-4 n1) (logical:ash-4 n2)) 16)
  49.         (- 15 (vector-ref (vector-ref logical:boole-and
  50.                       (- 15 (modulo n1 16)))
  51.                   (- 15 (modulo n2 16))))))))
  52.  
  53. (define (logical:logxor n1 n2)
  54.   (cond ((= n1 n2) 0)
  55.     ((zero? n1) n2)
  56.     ((zero? n2) n1)
  57.     (else
  58.      (+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16)
  59.         (vector-ref (vector-ref logical:boole-xor (modulo n1 16))
  60.             (modulo n2 16))))))
  61.  
  62. (define (logical:lognot n) (- -1 n))
  63.  
  64. (define (logical:logtest int1 int2)
  65.   (not (zero? (logical:logand int1 int2))))
  66.  
  67. (define (logical:logbit? index int)
  68.   (logical:logtest (logical:integer-expt 2 index) int))
  69.  
  70. (define (logical:copy-bit index to bool)
  71.   (if bool
  72.       (logical:logior to (logical:ash 1 index))
  73.       (logical:logand to (logical:lognot (logical:ash 1 index)))))
  74.  
  75. (define (logical:bit-field n start end)
  76.   (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
  77.           (logical:ash n (- start))))
  78.  
  79. (define (logical:bitwise-if mask n0 n1)
  80.   (logical:logior (logical:logand mask n0)
  81.           (logical:logand (logical:lognot mask) n1)))
  82.  
  83. (define (logical:copy-bit-field to start end from)
  84.   (logical:bitwise-if
  85.    (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start)
  86.    (logical:ash from start)
  87.    to))
  88.  
  89. (define (logical:ash int cnt)
  90.   (if (negative? cnt)
  91.       (let ((n (logical:integer-expt 2 (- cnt))))
  92.     (if (negative? int)
  93.         (+ -1 (quotient (+ 1 int) n))
  94.         (quotient int n)))
  95.       (* (logical:integer-expt 2 cnt) int)))
  96.  
  97. (define (logical:ash-4 x)
  98.   (if (negative? x)
  99.       (+ -1 (quotient (+ 1 x) 16))
  100.       (quotient x 16)))
  101.  
  102. (define (logical:logcount n)
  103.   (cond ((zero? n) 0)
  104.     ((negative? n) (logical:logcount (logical:lognot n)))
  105.     (else
  106.      (+ (logical:logcount (logical:ash-4 n))
  107.         (vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
  108.             (modulo n 16))))))
  109.  
  110. (define (logical:integer-length n)
  111.   (case n
  112.     ((0 -1) 0)
  113.     ((1 -2) 1)
  114.     ((2 3 -3 -4) 2)
  115.     ((4 5 6 7 -5 -6 -7 -8) 3)
  116.     (else (+ 4 (logical:integer-length (logical:ash-4 n))))))
  117.  
  118. (define logical:boole-xor
  119.  '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
  120.     #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14)
  121.     #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13)
  122.     #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12)
  123.     #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11)
  124.     #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10)
  125.     #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9)
  126.     #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8)
  127.     #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7)
  128.     #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6)
  129.     #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5)
  130.     #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4)
  131.     #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3)
  132.     #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2)
  133.     #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1)
  134.     #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)))
  135.  
  136. (define logical:boole-and
  137.  '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
  138.     #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1)
  139.     #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2)
  140.     #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3)
  141.     #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4)
  142.     #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5)
  143.     #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6)
  144.     #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7)
  145.     #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8)
  146.     #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9)
  147.     #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10)
  148.     #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11)
  149.     #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12)
  150.     #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13)
  151.     #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14)
  152.     #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
  153.  
  154. (define logand logical:logand)
  155. (define logior logical:logior)
  156. (define logxor logical:logxor)
  157. (define lognot logical:lognot)
  158. (define logtest logical:logtest)
  159. (define logbit? logical:logbit?)
  160. (define copy-bit logical:copy-bit)
  161. (define ash logical:ash)
  162. (define logcount logical:logcount)
  163. (define integer-length logical:integer-length)
  164. (define bit-field logical:bit-field)
  165. (define bit-extract logical:bit-field)
  166. (define copy-bit-field logical:copy-bit-field)
  167. (define ipow-by-squaring logical:ipow-by-squaring)
  168. (define integer-expt logical:integer-expt)
  169.