Import Debian changes 3a2-1debian/3a2-1

slib (3a2-1) unstable; urgency=low

  * New upstream release.
  * Acknowledge NMU. (Closes: #281809)
  * Makefile: Don't hack Makefile; use rules instead.
  * debian/rules: Set on make invocations: prefix, htmldir, TEXI2HTML.
  * debian/rules (clean): Clean more stuff here.
  * Makefile: Comment out old rule for $(htmldir)slib_toc.html.  Instead,
    specify directly that the texi2html invocation produces that file.
  * debian/rules (binary-indep): Find web files in slib subdir.
  
  * debian/control (Build-Depends-Indep): Go back to using scm.

1 files changed, 71 insertions, 114 deletions

diff --git a/logical.scm b/logical.scm
index 90808e6..5ea47f5 100644
--- a/logical.scm
+++ b/logical.scm
@@ -1,5 +1,5 @@
 ;;;; "logical.scm", bit access and operations for integers for Scheme
-;;; Copyright (C) 1991, 1993, 2001, 2003 Aubrey Jaffer
+;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -17,20 +17,6 @@
 ;promotional, or sales literature without prior written consent in
 ;each case.
 
-;@
-(define integer-expt
-  (if (provided? 'inexact)
-      expt
-      (lambda (n k)
-	(do ((x n (* x x))
-	     (j k (quotient j 2))
-	     (acc 1 (if (even? j) acc (* x acc))))
-	    ((<= j 1)
-	     (case j
-	       ((0) acc)
-	       ((1) (* x acc))
-	       (else (slib:error 'integer-expt n k))))))))
-
 (define logical:boole-xor
  '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
     #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14)
@@ -71,6 +57,13 @@
   (if (negative? x)
       (+ -1 (quotient (+ 1 x) 16))
       (quotient x 16)))
+
+(define (logical:reduce op4 ident)
+  (lambda args
+    (do ((res ident (op4 res (car rgs) 1 0))
+	 (rgs args (cdr rgs)))
+	((null? rgs) res))))
+
 ;@
 (define logand
   (letrec
@@ -87,7 +80,7 @@
 					       (modulo n2 16))
 				   scl)
 				acc)))))))
-    (lambda (n1 n2) (lgand n2 n1 1 0))))
+    (logical:reduce lgand -1)))
 ;@
 (define logior
   (letrec
@@ -105,7 +98,7 @@
 					  (- 15 (modulo n2 16))))
 				   scl)
 				acc)))))))
-    (lambda (n1 n2) (lgior n2 n1 1 0))))
+    (logical:reduce lgior 0)))
 ;@
 (define logxor
   (letrec
@@ -122,46 +115,52 @@
 					       (modulo n2 16))
 				   scl)
 				acc)))))))
-    (lambda (n1 n2) (lgxor n2 n1 1 0))))
+    (logical:reduce lgxor 0)))
 ;@
 (define (lognot n) (- -1 n))
 ;@
 (define (logtest n1 n2)
-  (not (zero? (logical:logand n1 n2))))
+  (not (zero? (logand n1 n2))))
 ;@
 (define (logbit? index n)
-  (logical:logtest (logical:integer-expt 2 index) n))
+  (logtest (expt 2 index) n))
 ;@
 (define (copy-bit index to bool)
   (if bool
-      (logical:logior to (logical:ash 1 index))
-      (logical:logand to (logical:lognot (logical:ash 1 index)))))
-
-;;@ This procedure is careful not to use more than DEG bits in
-;; computing (- (expt 2 DEG) 1)
-(define (logical:ones deg)
-  (if (zero? deg) 0 (+ (* 2 (+ -1 (logical:integer-expt 2 (- deg 1)))) 1)))
-;@
-(define (bit-field n start end)
-  (logical:logand (logical:ones (- end start))
-		  (logical:ash n (- start))))
+      (logior to (arithmetic-shift 1 index))
+      (logand to (lognot (arithmetic-shift 1 index)))))
 ;@
 (define (bitwise-if mask n0 n1)
-  (logical:logior (logical:logand mask n0)
-		  (logical:logand (logical:lognot mask) n1)))
-;@
-(define (copy-bit-field to start end from)
-  (logical:bitwise-if (logical:ash (logical:ones (- end start)) start)
-		      (logical:ash from start)
-		      to))
+  (logior (logand mask n0)
+	  (logand (lognot mask) n1)))
 ;@
-(define (ash n count)
+(define (bit-field n start end)
+  (logand (lognot (ash -1 (- end start)))
+	  (arithmetic-shift n (- start))))
+;@
+(define (copy-bit-field to from start end)
+  (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start)
+	      (arithmetic-shift from start)
+	      to))
+;@
+(define (rotate-bit-field n count start end)
+  (define width (- end start))
+  (set! count (modulo count width))
+  (let ((mask (lognot (ash -1 width))))
+    (define zn (logand mask (arithmetic-shift n (- start))))
+    (logior (arithmetic-shift
+	     (logior (logand mask (arithmetic-shift zn count))
+		     (arithmetic-shift zn (- count width)))
+	     start)
+	    (logand (lognot (ash mask start)) n))))
+;@
+(define (arithmetic-shift n count)
   (if (negative? count)
-      (let ((k (logical:integer-expt 2 (- count))))
+      (let ((k (expt 2 (- count))))
 	(if (negative? n)
 	    (+ -1 (quotient (+ 1 n) k))
 	    (quotient n k)))
-      (* (logical:integer-expt 2 count) n)))
+      (* (expt 2 count) n)))
 ;@
 (define integer-length
   (letrec ((intlen (lambda (n tot)
@@ -183,30 +182,33 @@
 				     (modulo n 16))
 				    tot))))))
     (lambda (n)
-      (cond ((negative? n) (logcnt (logical:lognot n) 0))
+      (cond ((negative? n) (logcnt (lognot n) 0))
 	    ((positive? n) (logcnt n 0))
 	    (else 0)))))
-
-;;;; Bit order and lamination
-;@
-(define (logical:rotate k count len)
-  (set! count (modulo count len))
-  (logical:logior (logical:logand (ash k count) (logical:ones len))
-		  (logical:ash k (- count len))))
 ;@
+(define (log2-binary-factors n)
+  (+ -1 (integer-length (logand n (- n)))))
+
 (define (bit-reverse k n)
-  (do ((m (if (negative? n) (lognot n) n) (ash m -1))
+  (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
        (k (+ -1 k) (+ -1 k))
-       (rvs 0 (logior (ash rvs 1) (logand 1 m))))
+       (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m))))
       ((negative? k) (if (negative? n) (lognot rvs) rvs))))
 ;@
+(define (reverse-bit-field n start end)
+  (define width (- end start))
+  (let ((mask (lognot (ash -1 width))))
+    (define zn (logand mask (arithmetic-shift n (- start))))
+    (logior (arithmetic-shift (bit-reverse width zn) start)
+	    (logand (lognot (ash mask start)) n))))
+;@
 (define (integer->list k . len)
   (if (null? len)
-      (do ((k k (ash k -1))
+      (do ((k k (arithmetic-shift k -1))
 	   (lst '() (cons (odd? k) lst)))
 	  ((<= k 0) lst))
       (do ((idx (+ -1 (car len)) (+ -1 idx))
-	   (k k (ash k -1))
+	   (k k (arithmetic-shift k -1))
 	   (lst '() (cons (odd? k) lst)))
 	  ((negative? idx) lst))))
 ;@
@@ -216,66 +218,21 @@
       ((null? bs) acc)))
 (define (booleans->integer . bools)
   (list->integer bools))
-;@
-(define (bitwise:laminate . ks)
-  (define nks (length ks))
-  (define nbs (apply max (map integer-length ks)))
-  (do ((kdx (+ -1 nbs) (+ -1 kdx))
-       (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks))
-		 (ash ibs nks))))
-      ((negative? kdx) ibs)))
-;@
-(define (bitwise:delaminate count k)
-  (define nbs (* count (+ 1 (quotient (integer-length k) count))))
-  (do ((kdx (- nbs count) (- kdx count))
-       (lst (vector->list (make-vector count 0))
-	    (map (lambda (k bool) (+ (if bool 1 0) (ash k 1)))
-		 lst
-		 (integer->list (ash k (- kdx)) count))))
-      ((negative? kdx) lst)))
 
-;;;; Gray-code
-;@
-(define (integer->gray-code k)
-  (logxor k (ash k -1)))
-;@
-(define (gray-code->integer k)
-  (if (negative? k)
-      (slib:error 'gray-code->integer 'negative? k)
-      (let ((kln (integer-length k)))
-	(do ((d 1 (* d 2))
-	     (ans (logxor k (ash k -1))	; == (integer->gray-code k)
-		  (logxor ans (ash ans (* d -2)))))
-	    ((>= (* 2 d) kln) ans)))))
-
-(define (grayter k1 k2)
-  (define kl1 (integer-length k1))
-  (define kl2 (integer-length k2))
-  (if (eqv? kl1 kl2)
-      (> (gray-code->integer k1) (gray-code->integer k2))
-      (> kl1 kl2)))
-;@
-(define (gray-code<? k1 k2)
-  (not (or (eqv? k1 k2) (grayter k1 k2))))
-(define (gray-code<=? k1 k2)
-  (or (eqv? k1 k2) (not (grayter k1 k2))))
-(define (gray-code>? k1 k2)
-  (and (not (eqv? k1 k2)) (grayter k1 k2)))
-(define (gray-code>=? k1 k2)
-  (or (eqv? k1 k2) (grayter k1 k2)))
+;;;;@ SRFI-60 aliases
+(define ash arithmetic-shift)
+(define bitwise-ior logior)
+(define bitwise-xor logxor)
+(define bitwise-and logand)
+(define bitwise-not lognot)
+(define bit-count logcount)
+(define bit-set?   logbit?)
+(define any-bits-set? logtest)
+(define first-set-bit log2-binary-factors)
+(define bitwise-merge bitwise-if)
+(provide 'srfi-60)
 
-(define logical:logand logand)
-(define logical:logior logior)
-;;(define logical:logxor logxor)
-(define logical:lognot lognot)
-(define logical:logtest logtest)
-;;(define logical:logbit? logbit?)
-;;(define logical:copy-bit copy-bit)
-(define logical:ash ash)
-;;(define logical:logcount logcount)
-;;(define logical:integer-length integer-length)
-;;(define logical:bit-field bit-field)
-;;(define bit-extract bit-field)
-(define logical:bitwise-if bitwise-if)
-;;(define logical:copy-bit-field copy-bit-field)
-(define logical:integer-expt integer-expt)
+;;; Legacy
+;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len))
+;;(define (logical:ones deg) (lognot (ash -1 deg)))
+;;(define integer-expt expt)		; legacy name