home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-bitstrings.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  6.8 KB  |  197 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-bitstrings.scm,v 1.7 1992/09/03 16:20:45 jmiller Exp $
  39.  
  40. ;;;; Support for handling integers as bit strings
  41.  
  42. ;;;
  43. ;;; UTILITY FUNCTIONS
  44. ;;;
  45.  
  46. (define (flip-bit bit) (if (= 0 bit) 1 0))
  47.  
  48. (define (negate-bits l)
  49.   (let loop ((answer '())
  50.          (remainder (reverse (map flip-bit l))))
  51.     (cond ((null? remainder) l)        ; (0 0 0 0 ...) was input
  52.       ((= (car remainder) 0)
  53.        (append (reverse (cdr remainder)) '(1) answer))
  54.       (else (loop (cons (flip-bit (car remainder)) answer)
  55.               (cdr remainder))))))
  56.  
  57. (define (integer->bits integer)
  58.   (if (negative? integer)
  59.       (let ((nbits (negate-bits (cdr (integer->bits (- integer))))))
  60.     (if (zero? (car nbits))
  61.         (cons 1 nbits)
  62.         nbits))
  63.       (let loop ((bits '())
  64.          (value integer))
  65.     (cond ((zero? value) (cons 0 bits))
  66.           ((even? value) (loop (cons 0 bits) (quotient value 2)))
  67.           (else (loop (cons 1 bits)
  68.               (quotient (- value 1) 2)))))))
  69.  
  70. (define (pad-bitstring-to n bits)
  71.   (let ((basic-bits (length bits)))
  72.     (if (< n basic-bits)
  73.     (dylan-call dylan:error "bitstring internal length error"))
  74.     (append
  75.      (vector->list
  76.       (make-vector (- n basic-bits) (if (null? bits) 0 (car bits))))
  77.      bits)))
  78.  
  79. (define (integers->same-length integer1 integer2 continue)
  80.   (let ((bits1 (integer->bits integer1))
  81.     (bits2 (integer->bits integer2)))
  82.     (let ((length1 (length bits1))
  83.       (length2 (length bits2)))
  84.       (cond ((= length1 length2) (continue bits1 bits2))
  85.         ((< length1 length2)
  86.          (continue (pad-bitstring-to length2 bits1) bits2))
  87.         (else
  88.          (continue bits1 (pad-bitstring-to length1 bits2)))))))
  89.  
  90. (define (bits->integer bits)
  91.   (define (unsigned->integer bits)
  92.     (let loop ((result 0)
  93.            (bits bits))
  94.       (if (null? bits)
  95.       result
  96.       (loop (+ (car bits) (* 2 result)) (cdr bits)))))
  97.   (cond ((zero? (car bits)) (unsigned->integer (cdr bits)))
  98.     ((null? (cdr bits)) -1)
  99.     (else (- (unsigned->integer (negate-bits (cdr bits)))))))
  100.  
  101. (define (logical-bitstr vals)
  102.   ;; Vals is a vector '#(0/0 0/1 1/0 1/1)
  103.   (lambda (int1 int2)
  104.     (bits->integer
  105.      (integers->same-length int1 int2
  106.        (lambda (bits1 bits2)
  107.      (map (lambda (a b) (vector-ref vals (+ (* 2 a) b)))
  108.           bits1 bits2))))))
  109.  
  110. (define (logical-op-only-rest-args no-arg-value vals)
  111.   (lambda all-integers
  112.     (if (not all-integers)
  113.     no-arg-value
  114.       (let loop ((integers-left (cdr all-integers))
  115.              (op-result (car all-integers)))
  116.         (if (null? integers-left)
  117.         op-result
  118.         (loop (cdr integers-left)
  119.               ((logical-bitstr vals) op-result (car integers-left))))))))
  120.  
  121. ;;;
  122. ;;; DYLAN FUNCTIONS
  123. ;;;
  124.  
  125. (define dylan:ash
  126.   ;; Assume (ash int count) shifts int left by count bits if count>0, right if
  127.   ;; count<0
  128.   (dylan::generic-fn 'ash two-integers
  129.     (lambda (integer shift)
  130.       (dylan-call dylan:floor (* (expt 2 shift) integer)))))
  131.  
  132. ;      (cond ((or (zero? shift) (zero? integer)) integer)
  133. ;        ((positive? shift) (* (expt 2 shift) integer))
  134. ;        (else
  135. ;         (let ((bits (integer->bits integer)))
  136. ;           (if (>= (- shift) (length bits))
  137. ;           (if (negative? integer) -1 0)
  138. ;           (quotient integer (expt 2 (- shift))))))))))
  139.  
  140. (define dylan:logand
  141.   (dylan::generic-fn 'logand only-rest-args
  142.     (logical-op-only-rest-args -1 '#(0 0 0 1))))
  143.  
  144. (define dylan:logandc1
  145.   (dylan::generic-fn 'logandc1 two-integers
  146.     (logical-bitstr '#(0 1 0 0))))
  147.  
  148. (define dylan:logandc2
  149.   (dylan::generic-fn 'logandc2 two-integers
  150.     (logical-bitstr '#(0 0 1 0))))
  151.  
  152. (define dylan:logbit?
  153.   ;; Assuming this is a bit index primitive with 0 being the low bit
  154.   ;; and assuming it should treat the integer as sign extended
  155.   ;; Number representation is 2's complement (sign extended)
  156.   (dylan::generic-fn 'logbit two-integers
  157.     (lambda (index integer)
  158.       (if (negative? index)
  159.       (dylan-call dylan:error "logbit? -- negative index" index integer))
  160.       (let* ((integer-bits (integer->bits integer))
  161.          (bit-index (- (length integer-bits) index 1)))
  162.     (if (negative? bit-index)
  163.         (negative? integer)
  164.         (= (list-ref integer-bits (- (length integer-bits) index 1)) 1))))))
  165.  
  166. (define dylan:logeqv
  167.   (dylan::generic-fn 'logeqv two-integers
  168.     (logical-op-only-rest-args -1 '#(1 0 0 1))))
  169.  
  170. (define dylan:logior
  171.   (dylan::generic-fn 'logior only-rest-args
  172.     (logical-op-only-rest-args 0 '#(0 1 1 1))))
  173.  
  174. (define dylan:lognand
  175.   (dylan::generic-fn 'lognand two-integers
  176.     (logical-bitstr '#(1 1 1 0))))
  177.  
  178. (define dylan:lognor
  179.   (dylan::generic-fn 'lognor two-integers
  180.     (logical-bitstr '#(1 0 0 0))))
  181.  
  182. (define dylan:lognot
  183.   (dylan::generic-fn 'lognot one-integer
  184.     (lambda (integer)
  185.       (bits->integer (map flip-bit (integer->bits integer))))))
  186.  
  187. (define dylan:logorc1
  188.   (dylan::generic-fn 'logorc1 two-integers
  189.     (logical-bitstr '#(1 1 0 1))))
  190.  
  191. (define dylan:logorc2
  192.   (dylan::generic-fn 'logorc2 two-integers
  193.     (logical-bitstr '#(1 0 1 1))))
  194.  
  195. (define dylan:logxor
  196.   (dylan::generic-fn 'logxor two-integers
  197.     (logical-op-only-rest-args 0 '#(0 1 1 0))))