Import Debian changes 2d2-1debian/2d2-1

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

  * New upstream version
  * Revert back to free.  Is now so.

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

  * New upstream version.
  * Move to non-free.  FSF pointed out license doesn't allow modified
    versions to be distributed.
  * Get a complete list of copyrights that apply to the source into
    copyright file.
  * Remove setup for guile 1.3.
  * Remove postrm.  Just calling install-info (lintian)  Move install-info
    call to prerm since doc-base doesn't do install-info.

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

  * Change info location to section "The Algorithmic Language Scheme" to
    match up with where guile puts it's files.
  * Postinst is running slibconfig now.  (Closes: #75891)

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

  * Stop installing slibconfig (for guile).
  * In postinst if /usr/sbin/slibconnfig exists call it (Close: #75843
    #75891).

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

  * New upstream (Closes: #74760)
  * replace string-index with strsrch:string-index in http-cgi.scm.
  * Add doc-base support (Closes: #31163)

1 files changed, 190 insertions, 176 deletions

diff --git a/printf.scm b/printf.scm
index da7178c..d17cf79 100644
--- a/printf.scm
+++ b/printf.scm
@@ -1,9 +1,9 @@
 ;;;; "printf.scm" Implementation of standard C functions for Scheme
-;;; Copyright (C) 1991-1993, 1996 Aubrey Jaffer.
+;;; Copyright (C) 1991-1993, 1996, 1999-2001 Aubrey Jaffer and Radey Shouman.
 ;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
 ;
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
@@ -19,117 +19,112 @@
 
 (require 'string-case)
 
-;; Parse the output of NUMBER->STRING.
-;; Returns a list: (sign-character digit-string exponent-integer)
+;; Determine the case of digits > 9.  We assume this to be constant.
+(define stdio:hex-upper-case? (string=? "-F" (number->string -15 16)))
+
+;; Parse the output of NUMBER->STRING and pass the results to PROC.
+;; PROC takes (SIGN-CHARACTER DIGIT-STRING EXPONENT-INTEGER . IMAGPART)
 ;; SIGN-CHAR will be either #\+ or #\-, DIGIT-STRING will always begin
 ;; with a "0", after which a decimal point should be understood.
-;; If STR denotes a non-real number, 3 additional elements for the
-;; complex part are appended.
-(define (stdio:parse-float str)
-  (let ((n (string-length str))
-	(iend 0))
-    (letrec ((prefix
-	      (lambda (i rest)
-		(if (and (< i (- n 1))
-			 (char=? #\# (string-ref str i)))
-		    (case (string-ref str (+ i 1))
-		      ((#\d #\i #\e) (prefix (+ i 2) rest))
-		      ((#\.) (rest i))
-		      (else (parse-error)))
-		    (rest i))))
-	     (sign
-	      (lambda (i rest)
-		(if (< i n)
-		    (let ((c (string-ref str i)))
-		      (case c
-			((#\- #\+) (cons c (rest (+ i 1))))
-			(else (cons #\+ (rest i))))))))
-	     (digits
-	      (lambda (i rest)
-		(do ((j i (+ j 1)))
-		    ((or (>= j n)
-			 (not (or (char-numeric? (string-ref str j))
-				  (char=? #\# (string-ref str j)))))
-		     (cons
-		      (if (= i j) "0" (substring str i j))
-		      (rest j))))))
-	     (point
-	      (lambda (i rest)
-		(if (and (< i n)
-			 (char=? #\. (string-ref str i)))
-		    (rest (+ i 1))
-		    (rest i))))
-	     (exp
-	      (lambda (i)
-		(if (< i n)
-		    (case (string-ref str i)
-		      ((#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L)
-		       (let ((s (sign (+ i 1) (lambda (i) (digits i end!)))))
-			 (list
-			  (if (char=? #\- (car s))
-			      (- (string->number (cadr s)))
-			      (string->number (cadr s))))))
-		      (else (end! i)
-			    '(0)))
-		    (begin (end! i)
-			   '(0)))))
-	     (end!
-	      (lambda (i)
-		(set! iend i)
-		'()))
-	     (real
-	      (lambda (i)
-		(let ((parsed
-		       (prefix
-			i
-			(lambda (i)
-			  (sign
-			   i
-			   (lambda (i)
-			     (digits
-			      i
-			      (lambda (i)
-				(point
-				 i
-				 (lambda (i)
-				   (digits i exp)))))))))))
-		  (and (list? parsed)
-		       (apply
-			(lambda (sgn idigs fdigs exp)
-			  (let* ((digs (string-append "0" idigs fdigs))
-				 (n (string-length digs)))
-			    (let loop ((i 1)
-				       (exp (+ exp (string-length idigs))))
-			      (if (and (< i n)
-				       (char=? #\0 (string-ref digs i)))
-				  (loop (+ i 1) (- exp 1))
-				  (list sgn (substring digs (- i 1) n) exp)))))
-			parsed)))))
-	     (parse-error
-	      (lambda () #f)))
-      (let ((realpart (real 0)))
-	(cond ((= iend n) realpart)
-	      ((memv (string-ref str iend) '(#\+ #\-))
-	       (let ((complexpart (real iend)))
-		 (and (= iend (- n 1))
-		      (char-ci=? #\i (string-ref str iend))
-		      (append realpart complexpart))))
-	      ((eqv? (string-ref str iend) #\@)
-	       ;; Polar form:  No point in parsing the angle ourselves,
-	       ;; since some transcendental approximation is unavoidable.
-	       (let ((num (string->number str)))
-		 (and num
-		      (let ((realpart
-			     (stdio:parse-float
-			      (number->string (real-part num))))
-			    (imagpart
-			     (if (real? num)
-				 '()
-				 (stdio:parse-float
-				  (number->string (imag-part num))))))
-			(and realpart imagpart
-			     (append realpart imagpart))))))
-	      (else #f))))))
+;; If STR denotes a number with imaginary part not exactly zero,
+;; 3 additional elements for the imaginary part are passed.
+;; If STR cannot be parsed, return #F without calling PROC.
+(define (stdio:parse-float str proc)
+  (let ((n (string-length str)))
+    (define (parse-error) #f)
+    (define (prefix i cont)
+      (if (and (< i (- n 1))
+	       (char=? #\# (string-ref str i)))
+	  (case (string-ref str (+ i 1))
+	    ((#\d #\i #\e) (prefix (+ i 2) cont))
+	    ((#\.) (cont i))
+	    (else (parse-error)))
+	  (cont i)))
+    (define (sign i cont)
+      (if (< i n)
+	  (let ((c (string-ref str i)))
+	    (case c
+	      ((#\- #\+) (cont (+ i 1) c))
+	      (else (cont i #\+))))))
+    (define (digits i cont)
+      (do ((j i (+ j 1)))
+	  ((or (>= j n)
+	       (not (or (char-numeric? (string-ref str j))
+			(char=? #\# (string-ref str j)))))
+	   (cont j (if (= i j) "0" (substring str i j))))))
+    (define (point i cont)
+      (if (and (< i n)
+	       (char=? #\. (string-ref str i)))
+	  (cont (+ i 1))
+	  (cont i)))
+    (define (exp i cont)
+      (cond ((>= i n) (cont i 0))
+	    ((memv (string-ref str i)
+		   '(#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L))
+	     (sign (+ i 1)
+		   (lambda (i sgn)
+		     (digits i
+			     (lambda (i digs)
+			       (cont i
+				     (if (char=? #\- sgn)
+					 (- (string->number digs))
+					 (string->number digs))))))))
+	    (else (cont i 0))))
+    (define (real i cont)
+      (prefix
+       i
+       (lambda (i)
+	 (sign
+	  i
+	  (lambda (i sgn)
+	    (digits
+	     i
+	     (lambda (i idigs)
+	       (point
+		i
+		(lambda (i)
+		  (digits
+		   i
+		   (lambda (i fdigs)
+		     (exp i
+			  (lambda (i ex)
+			    (let* ((digs (string-append "0" idigs fdigs))
+				   (ndigs (string-length digs)))
+			      (let loop ((j 1)
+					 (ex (+ ex (string-length idigs))))
+				(cond ((>= j ndigs) ;; Zero
+				       (cont i sgn "0" 1))
+				      ((char=? #\0 (string-ref digs j))
+				       (loop (+ j 1) (- ex 1)))
+				      (else
+				       (cont i sgn
+					     (substring digs (- j 1) ndigs)
+					     ex))))))))))))))))))
+    (real 0
+	  (lambda (i sgn digs ex)
+	    (cond
+	     ((= i n) (proc sgn digs ex))
+	     ((memv (string-ref str i) '(#\+ #\-))
+	      (real i
+		    (lambda (j im-sgn im-digs im-ex)
+		      (if (and (= j (- n 1))
+			       (char-ci=? #\i (string-ref str j)))
+			  (proc sgn digs ex im-sgn im-digs im-ex)
+			  (parse-error)))))
+	     ((eqv? (string-ref str i) #\@)
+	      ;; Polar form: No point in parsing the angle ourselves,
+	      ;; since some transcendental approximation is unavoidable.
+	      (let ((num (string->number str)))
+		(if num
+		    (stdio:parse-float
+		     (number->string (real-part num))
+		     (lambda (sgn digs ex)
+		       (stdio:parse-float
+			(number->string (imag-part num))
+			(lambda (im-sgn im-digs im-ex)
+			  (proc sgn digs ex im-sgn im-digs im-ex)))))
+		    (parse-error))))
+	     (else #f))))))
 
 ;; STR is a digit string representing a floating point mantissa, STR must
 ;; begin with "0", after which a decimal point is understood.
@@ -144,13 +139,14 @@
 	  (cond ((< ndigs 0) "")
 		((= n ndigs) str)
 		((< n ndigs)
-		 (let ((zeropad (make-string
-				 (max 0 (- (or strip-0s ndigs) n))
-				 (if (char-numeric? (string-ref str n))
-				     #\0 #\#))))
-		   (if (zero? (string-length zeropad))
+		 (let ((padlen (max 0 (- (or strip-0s ndigs) n))))
+		   (if (zero? padlen)
 		       str
-		       (string-append str zeropad))))
+		       (string-append str
+				      (make-string padlen
+						   (if (char-numeric?
+							(string-ref str n))
+						       #\0 #\#))))))
 		(else
 		 (let ((res (substring str 0 (+ ndigs 1)))
 		       (dig (lambda (i)
@@ -162,7 +158,8 @@
 		     (if (or (> ldig 5)
 			     (and (= ldig 5)
 				  (let loop ((i (+ 2 ndigs)))
-				    (if (> i n) (odd? (dig ndigs))
+				    (if (> i n)
+					(odd? (dig ndigs))
 					(if (zero? (dig i))
 					    (loop (+ i 1))
 					    #t)))))
@@ -208,6 +205,12 @@
 	(slib:error 'printf "wrong number of arguments"
 		    (length args)
 		    format-string))
+      (define (out* strs)
+	(if (string? strs) (out strs)
+	    (let out-loop ((strs strs))
+	      (or (null? strs)
+		  (and (out (car strs))
+		       (out-loop (cdr strs)))))))
 
       (let loop ((args args))
 	(advance)
@@ -252,27 +255,24 @@
 	    (define (pad pre . strs)
 	      (let loop ((len (string-length pre))
 			 (ss strs))
-		(cond ((>= len width) (apply string-append pre strs))
+		(cond ((>= len width) (cons pre strs))
 		      ((null? ss)
 		       (cond (left-adjust
-			      (apply string-append
-				     pre
-				     (append strs
-					     (list (make-string
-						    (- width len) #\space)))))
+			      (cons pre
+				    (append strs
+					    (list (make-string
+						   (- width len) #\space)))))
 			     (leading-0s
-			      (apply string-append
-				     pre
-				     (make-string (- width len) #\0)
-				     strs))
+			      (cons pre
+				    (cons (make-string (- width len) #\0)
+					  strs)))
 			     (else
-			      (apply string-append
-				     (make-string (- width len) #\space)
-				     pre strs))))
+			      (cons (make-string (- width len) #\space)
+				    (cons pre strs)))))
 		      (else
 		       (loop (+ len (string-length (car ss))) (cdr ss))))))
 	    (define integer-convert
-	      (lambda (s radix)
+	      (lambda (s radix fixcase)
 		(cond ((not (negative? precision))
 		       (set! leading-0s #f)
 		       (if (and (zero? precision)
@@ -283,6 +283,7 @@
 			      ((or (not s) (null? s)) "0")
 			      ((string? s) s)
 			      (else "1")))
+		(if fixcase (set! s (fixcase s)))
 		(let ((pre (cond ((equal? "" s) "")
 				 ((eqv? #\- (string-ref s 0))
 				  (set! s (substring s 1 (string-length s)))
@@ -380,26 +381,28 @@
 			     (number->string (exact->inexact num)))
 			    ((string? num) num)
 			    ((symbol? num) (symbol->string num))
-			    (else "???")))
-		     (parsed (stdio:parse-float str)))
-		(letrec ((format-real
-			  (lambda (signed? sgn digs exp . rest)
-			    (if (null? rest)
-				(cons
-				 (if (char=? #\- sgn) "-"
-				     (if signed? "+" (if blank " " "")))
-				 (case fc
-				   ((#\e #\E) (e digs exp #f))
-				   ((#\f #\F) (f digs exp #f))
-				   ((#\g #\G) (g digs exp))
-				   ((#\k) (k digs exp ""))
-				   ((#\K) (k digs exp " "))))
-				(append (format-real signed? sgn digs exp)
-					(apply format-real #t rest)
-					'("i"))))))
-		  (if parsed
-		      (apply pad (apply format-real signed parsed))
-		      (pad "???")))))
+			    (else "???"))))
+		(define (format-real signed? sgn digs exp . rest)
+		  (if (null? rest)
+		      (cons
+		       (if (char=? #\- sgn) "-"
+			   (if signed? "+" (if blank " " "")))
+		       (case fc
+			 ((#\e #\E) (e digs exp #f))
+			 ((#\f #\F) (f digs exp #f))
+			 ((#\g #\G) (g digs exp))
+			 ((#\k) (k digs exp ""))
+			 ((#\K) (k digs exp " "))))
+		      (append (format-real signed? sgn digs exp)
+			      (apply format-real #t rest)
+			      '("i"))))
+		(or (stdio:parse-float str
+				    (lambda (sgn digs expon . imag)
+				      (apply pad
+					     (apply format-real
+						    signed
+						    sgn digs expon imag))))
+		    (pad "???"))))
 	    (do ()
 		((case fc
 		   ((#\-) (set! left-adjust #t) #f)
@@ -432,7 +435,7 @@
 		    (wna)))
 
 	    (case fc
-	      ;; only - is allowed between % and c
+		;; only - is allowed between % and c
 	      ((#\c #\C)		; C is enhancement
 	       (and (out (string (car args))) (loop (cdr args))))
 
@@ -445,18 +448,20 @@
 		 (cond ((not (or (negative? precision)
 				 (>= precision (string-length s))))
 			(set! s (substring s 0 precision))))
-		 (and (out (cond
-			    ((<= width (string-length s)) s)
-			    (left-adjust
-			     (string-append
-			      s (make-string (- width (string-length s)) #\ )))
-			    (else
-			     (string-append
-			      (make-string (- width (string-length s))
-					   (if leading-0s #\0 #\ )) s))))
-		      (loop (cdr args)))))
+		 (and
+		  (out* (cond
+			 ((<= width (string-length s)) s)
+			 (left-adjust
+			  (list
+			   s (make-string (- width (string-length s)) #\ )))
+			 (else
+			  (list
+			   (make-string (- width (string-length s))
+					(if leading-0s #\0 #\ ))
+			   s))))
+		  (loop (cdr args)))))
 
-	      ;; SLIB extension
+		;; SLIB extension
 	      ((#\a #\A)		;#\a #\A are pretty-print
 	       (require 'generic-write)
 	       (let ((os "") (pr precision))
@@ -508,22 +513,31 @@
 				  (out os)))))
 	       (loop (cdr args)))
 	      ((#\d #\D #\i #\I #\u #\U)
-	       (and (out (integer-convert (car args) 10)) (loop (cdr args))))
+	       (and (out* (integer-convert (car args) 10 #f))
+		    (loop (cdr args))))
 	      ((#\o #\O)
-	       (and (out (integer-convert (car args) 8)) (loop (cdr args))))
-	      ((#\x #\X)
-	       (and (out ((if (char-upper-case? fc)
-			      string-upcase string-downcase)
-			  (integer-convert (car args) 16)))
+	       (and (out* (integer-convert (car args) 8 #f))
+		    (loop (cdr args))))
+	      ((#\x)
+	       (and (out* (integer-convert
+			   (car args) 16
+			   (if stdio:hex-upper-case? string-downcase #f)))
+		    (loop (cdr args))))
+	       ((#\X)
+	       (and (out* (integer-convert
+			   (car args) 16
+			   (if stdio:hex-upper-case? #f string-upcase)))
 		    (loop (cdr args))))
 	      ((#\b #\B)
-	       (and (out (integer-convert (car args) 2)) (loop (cdr args))))
+	       (and (out* (integer-convert (car args) 2 #f))
+		    (loop (cdr args))))
 	      ((#\%) (and (out #\%) (loop args)))
 	      ((#\f #\F #\e #\E #\g #\G #\k #\K)
-	       (and (out (float-convert (car args) fc)) (loop (cdr args))))
+	       (and (out* (float-convert (car args) fc)) (loop (cdr args))))
 	      (else
-	       (cond ((end-of-format?) (incomplete))
-		     (else (and (out #\%) (out fc) (out #\?) (loop args))))))))
+	       (cond
+		((end-of-format?) (incomplete))
+		(else (and (out #\%) (out fc) (out #\?) (loop args))))))))
 	 (else (and (out fc) (loop args)))))))))
 
 (define (stdio:fprintf port format . args)