Import Debian changes 3a1-4.2debian/3a1-4.2

slib (3a1-4.2) unstable; urgency=low

  * Non-maintainer upload.
  * Add guile.init.local for use within the build dir, since otherwise we
    have an (earlier unnoticed) circular build-dep due to a difference
    between scm and guile.

slib (3a1-4.1) unstable; urgency=low

  * Non-maintainer upload.
  * Build-depend on guile-1.6 instead of scm, since the new version of
    scm is wedged in unstable (closes: #281809).

slib (3a1-4) unstable; urgency=low

  * Also check for expected creation on slibcat. (Closes: #240096)

slib (3a1-3) unstable; urgency=low

  * Also check for /usr/share/guile/1.6/slib before installing for guile
    1.6. (Closes: #239267)

slib (3a1-2) unstable; urgency=low

  * Add format.scm back into slib until gnucash stops using it.
  * Call guile-1.6 new-catalog (Closes: #238231)

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

  * New upstream release
  * Remove Info section from doc-base file (Closes: #186950)
  * Remove period from end of description (linda, lintian)
  * html gen fixed upstream (Closes: #111778)

slib (2d4-2) unstable; urgency=low

  * Fix url for upstream source (Closes: #144981)
  * Fix typo in slib.texi (enquque->enqueue) (Closes: #147475)
  * Add build depends.

slib (2d4-1) unstable; urgency=low

  * New upstream.

slib (2d3-1) unstable; urgency=low

  * New upstream.
  * Remove texi2html call in debian/rules.  Now done upstream.  Add make
    html instead.
  * Changes to rules and doc-base to conform to upstream html gen
  * Clean up upstream makefile to make sure it cleans up after itself.

1 files changed, 218 insertions, 12 deletions

diff --git a/srfi-1.scm b/srfi-1.scm
index 1cebd9a..d0f436f 100644
--- a/srfi-1.scm
+++ b/srfi-1.scm
@@ -1,5 +1,6 @@
 ;;; "srfi-1.scm" SRFI-1 list-processing library		-*-scheme-*-
-; Copyright 2001 Aubrey Jaffer
+;; Copyright 2001 Aubrey Jaffer
+;; Copyright 2003 Sven Hartrumpf
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +9,7 @@
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
 ;
-;2.  I have made no warrantee or representation that the operation of
+;2.  I have made no warranty or representation that the operation of
 ;this software will be error-free, and I am under no obligation to
 ;provide any services, by way of maintenance, update, or otherwise.
 ;
@@ -48,7 +49,10 @@
       ((< i 0) ans)))
 
 ;;@args obj1 obj2
-(define cons* comlist:list*)
+(define cons* list*)
+
+;;@args flist
+(define list-copy copy-list)
 
 ;;@args count start step
 ;;@args count start
@@ -112,9 +116,13 @@
 
 ;;@args pair
 (define first  car)
+;;@args pair
 (define second cadr)
+;;@args pair
 (define third  caddr)
+;;@args pair
 (define fourth cadddr)
+;;@args pair
 (define (fifth   obj) (car    (cddddr obj)))
 (define (sixth   obj) (cadr   (cddddr obj)))
 (define (seventh obj) (caddr  (cddddr obj)))
@@ -126,17 +134,21 @@
 (define (car+cdr pair) (values (car pair) (cdr pair)))
 
 ;;@body
-(define (take lst k) (comlist:butnthcdr k lst))
+(define (drop lst k) (nthcdr k lst))
+(define (take lst k) (butnthcdr k lst))
+;;@args lst k
 (define take! take)
-(define (drop lst k) (comlist:nthcdr k lst))
 
 ;;@args lst k
-(define take-right comlist:butlast)
-(define drop-right comlist:last)
+(define take-right last)
+;;@args lst k
+(define drop-right butlast)
+;;@args lst k
 (define drop-right! drop-right)
 
-;;@body
+;;@args lst k
 (define (split-at lst k) (values (take lst k) (drop lst k)))
+;;@args lst k
 (define split-at! split-at)
 
 ;;@args lst
@@ -144,7 +156,7 @@
 (define (last lst . k)
   (if (null? k)
       (car (last-pair lst))
-      (apply comlist:last lst k)))
+      (apply take-right lst k)))
 
 ;;@subheading Miscellaneous
 
@@ -159,7 +171,7 @@
 
 ;;Reverse is provided by R4RS.
 ;;@args lst
-(define reverse! comlist:nreverse)
+(define reverse! nreverse)
 
 ;;@body
 (define (append-reverse rev-head tail)
@@ -202,16 +214,159 @@
 
 ;;@subheading Fold and Unfold
 
+
+;;; We stop when LIS1 runs out, not when any list runs out.
+;;@args f list1 clist2 ...
+(define (map! f lis1 . lists)
+  (if (pair? lists)
+      (let lp ((lis1 lis1) (lists lists))
+	(if (not (null-list? lis1))
+	    (call-with-values ; expanded a receive call
+              (lambda () (%cars+cdrs/no-test lists))
+              (lambda (heads tails)
+                (set-car! lis1 (apply f (car lis1) heads))
+                (lp (cdr lis1) tails)))))
+
+      ;; Fast path.
+      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+  lis1)
+
+;;@args f clist1 clist2 ...
+(define (pair-for-each proc lis1 . lists)
+  (if (pair? lists)
+      (let lp ((lists (cons lis1 lists)))
+	(let ((tails (%cdrs lists)))
+	  (if (pair? tails)
+	      (begin (apply proc lists)
+		     (lp tails)))))
+      ;; Fast path.
+      (let lp ((lis lis1))
+	(if (not (null-list? lis))
+	    (let ((tail (cdr lis)))	; Grab the cdr now,
+	      (proc lis)		; in case PROC SET-CDR!s LIS.
+	      (lp tail))))))
+
+
 ;;@subheading Filtering and Partitioning
 
+;;@body
+(define (filter pred lis)			; Sleazing with EQ? makes this one faster.
+  (let recur ((lis lis))
+    (if (null-list? lis) lis			; Use NOT-PAIR? to handle dotted lists.
+	(let ((head (car lis))
+	      (tail (cdr lis)))
+	  (if (pred head)
+	      (let ((new-tail (recur tail)))	; Replicate the RECUR call so
+		(if (eq? tail new-tail) lis
+		    (cons head new-tail)))
+	      (recur tail))))))			; this one can be a tail call.
+;;@body
+(define (filter! pred l)
+  (if (null? l)
+      l
+      (let ((l2 l)
+	    (l3 (cdr l)))
+	(do ((end #f)
+	     (result '()))
+	    (end result)
+	  (cond ((pred (car l2))	; keep the first element of l2
+		 (cond ((null? result)
+			(set! result l2))) ; first pair of remaining elements
+		 (cond ((pair? l3)
+			(set! l2 l3)
+			(set! l3 (cdr l2)))
+		       (else
+			(set! end #t))))
+		(else		      ; remove the first element of l2
+		 (cond ((pair? l3)
+			(set-car! l2 (car l3))
+			(set! l3 (cdr l3))
+			(set-cdr! l2 l3))
+		       (else
+			(cond ((pair? result)
+			       (list-remove-last! result)))
+			(set! end #t)))))))))
+
+;;@args pred list
+(define (partition pred lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle dotted lists.
+	(let ((elt (car lis))
+	      (tail (cdr lis)))
+	  (call-with-values ; expanded a receive call
+            (lambda () (recur tail))
+            (lambda (in out)
+              (if (pred elt)
+                (values (if (pair? out) (cons elt in) lis) out)
+                (values in (if (pair? in) (cons elt out) lis)))))))))
+
 ;;@subheading Searching
 
 ;;@args pred list
-(define find comlist:find-if)
+(define find find-if)
 
 ;;@args pred list
-(define find-tail comlist:member-if)
+(define find-tail member-if)
 
+;;@body
+(define remove
+  (let ((comlist:remove remove))
+    (lambda (pred l)
+      (if (procedure? pred)
+	  (filter (lambda (x) (not (pred x))) l)
+	  (comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB!
+;;@body
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+;;@args pred clist1 clist2 ...
+(define (any pred lis1 . lists)
+  (if (pair? lists)
+      ;; N-ary case
+      (call-with-values ; expanded a receive call
+        (lambda () (%cars+cdrs (cons lis1 lists)))
+        (lambda (heads tails)
+          (and (pair? heads)
+               (let lp ((heads heads) (tails tails))
+                 (call-with-values ; expanded a receive call
+                   (lambda () (%cars+cdrs tails))
+                   (lambda (next-heads next-tails)
+                     (if (pair? next-heads)
+                       (or (apply pred heads) (lp next-heads next-tails))
+                       (apply pred heads)))))))) ; Last PRED app is tail call.
+      ;; Fast path
+      (and (not (null-list? lis1))
+	   (let lp ((head (car lis1)) (tail (cdr lis1)))
+	     (if (null-list? tail)
+		 (pred head)		; Last PRED app is tail call.
+		 (or (pred head) (lp (car tail) (cdr tail))))))))
+
+;;@args pred clist1 clist2 ...
+(define (list-index pred lis1 . lists)
+  (if (pair? lists)
+      ;; N-ary case
+      (let lp ((lists (cons lis1 lists)) (n 0))
+        (call-with-values ; expanded a receive call
+          (lambda () (%cars+cdrs lists))
+                (lambda (heads tails)
+            (and (pair? heads)
+                 (if (apply pred heads) n
+                   (lp tails (+ n 1)))))))
+      ;; Fast path
+      (let lp ((lis lis1) (n 0))
+	(and (not (null-list? lis))
+	     (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+;;@args pred list
+(define (span pred lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values '() '())
+	(let ((x (car lis)))
+	  (if (pred x)
+	      (call-with-values ; eliminated a receive call
+                (lambda () (recur (cdr lis)))
+                (lambda (prefix suffix)
+                  (values (cons x prefix) suffix)))
+	      (values '() lis))))))
 
 ;;@args obj list pred
 ;;@args obj list
@@ -251,3 +406,54 @@
 	    (find (lambda (pair) (pred obj (car pair))) alist))))))
 
 ;;@subheading Set operations
+
+
+;;;; helper functions from the reference implementation:
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (%cars+cdrs lists)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+        (if (pair? lists)
+	    (call-with-values ; expanded a receive call
+              (lambda () (car+cdr lists))
+              (lambda (list other-lists)
+                (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+                  (call-with-values ; expanded a receive call
+                    (lambda () (car+cdr list))
+                    (lambda (a d)
+                      (call-with-values ; expanded a receive call
+                        (lambda () (recur other-lists))
+                        (lambda (cars cdrs)
+                          (values (cons a cars) (cons d cdrs)))))))))
+            (values '() '()))))))
+
+;;; Like %CARS+CDRS, but blow up if any list is empty.
+(define (%cars+cdrs/no-test lists)
+  (let recur ((lists lists))
+    (if (pair? lists)
+      (call-with-values ; expanded a receive call
+        (lambda () (car+cdr lists))
+        (lambda (list other-lists)
+          (call-with-values ; expanded a receive call
+            (lambda () (car+cdr list))
+            (lambda (a d)
+              (call-with-values ; expanded a receive call
+                (lambda () (recur other-lists))
+                (lambda (cars cdrs)
+                  (values (cons a cars) (cons d cdrs))))))))
+      (values '() '()))))
+
+(define (%cdrs lists)
+  (call-with-current-continuation
+    (lambda (abort)
+      (let recur ((lists lists))
+	(if (pair? lists)
+	    (let ((lis (car lists)))
+	      (if (null-list? lis) (abort '())
+		  (cons (cdr lis) (recur (cdr lists)))))
+	    '())))))