Import Upstream version 2c7upstream/2c7

1 files changed, 73 insertions, 76 deletions

diff --git a/format.scm b/format.scm
index e64efa7..d9f1c86 100644
--- a/format.scm
+++ b/format.scm
@@ -113,9 +113,9 @@
 		  (substring format-string 0 format:pos)
 		  (substring format-string format:pos
 			     (string-length format-string))
-		  (list-head (cddr format:args) format:arg-pos)
+		  (format:list-head (cddr format:args) format:arg-pos)
 		  (list-tail (cddr format:args) format:arg-pos)))
-	(format port 
+	(format port
 		"~%FORMAT: error with call: (format~{ ~a~})~%        "
 		format:args))
     (apply format port args)
@@ -140,28 +140,34 @@
   (set! format:pos 0)
   (if (< (length args) 1)
       (format:error "not enough arguments"))
-  (let ((destination (car args))
-	(arglist (cdr args)))
-    (cond
-     ((or (and (boolean? destination)	; port output
-	       destination)
-	  (output-port? destination)
-	  (number? destination))
-      (format:out (cond
-		   ((boolean? destination) (current-output-port))
-		   ((output-port? destination) destination)
-		   ((number? destination) (current-error-port)))
-		  (car arglist) (cdr arglist)))
-     ((and (boolean? destination)	; string output
-	   (not destination))
-      (call-with-output-string
-       (lambda (port) (format:out port (car arglist) (cdr arglist)))))
-     ((string? destination)		; dest. is format string (Scheme->C)
-      (call-with-output-string
-       (lambda (port)
-	 (format:out port destination arglist))))
-     (else
-      (format:error "illegal destination `~a'" destination)))))
+
+  ;; If the first argument is a string, then that's the format string.
+  ;; (Scheme->C)
+  ;; In this case, put the argument list in canonical form.
+  (let ((args (if (string? (car args))
+		  (cons #f args)
+		  args)))
+    ;; Use this canonicalized version when reporting errors.
+    (set! format:args args)
+
+    (let ((destination (car args))
+	  (arglist (cdr args)))
+      (cond
+       ((or (and (boolean? destination)	; port output
+		 destination)
+	    (output-port? destination)
+	    (number? destination))
+	(format:out (cond
+		     ((boolean? destination) (current-output-port))
+		     ((output-port? destination) destination)
+		     ((number? destination) (current-error-port)))
+		    (car arglist) (cdr arglist)))
+       ((and (boolean? destination)	; string output
+	     (not destination))
+	(call-with-output-string
+	 (lambda (port) (format:out port (car arglist) (cdr arglist)))))
+       (else
+	(format:error "illegal destination `~a'" destination))))))
 
 (define (format:out port fmt args)	; the output handler for a port
   (set! format:port port)		; global port for output routines
@@ -248,7 +254,7 @@
 	    (if (= k 0) l (loop (cdr l) (- k 1))))))
 
        (add-arg-pos
-	(lambda (n) 
+	(lambda (n)
 	  (set! arg-pos (+ n arg-pos))
 	  (set! format:arg-pos arg-pos)))
 
@@ -491,7 +497,7 @@
 	      ((#\()			; Case conversion begin
 	       (set! format:case-conversion
 		     (case modifier
-		       ((at) string-capitalize-first)
+		       ((at) format:string-capitalize-first)
 		       ((colon) string-capitalize)
 		       ((colon-at) string-upcase)
 		       (else string-downcase)))
@@ -529,7 +535,7 @@
 			  (cond
 			   ((eq? modifier 'colon)
 			    (set! clause-default #t)
-			    (substring format-string clause-pos 
+			    (substring format-string clause-pos
 				       (- format:pos 3)))
 			   ((memq modifier '(at colon-at))
 			    (format:error "illegal modifier in ~~;"))
@@ -689,13 +695,14 @@
 	      ;; format directive modifiers and parameters
 
 	      ((#\@)			; `@' modifier
-	       (if (eq? modifier 'colon-at)
+	       (if (memq modifier '(at colon-at))
 		   (format:error "double `@' modifier"))
 	       (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
 	       (tilde-dispatch))
 	      ((#\:)			; `:' modifier
-	       (if modifier (format:error "illegal `:' modifier position"))
-	       (set! modifier 'colon)
+	       (if (memq modifier '(colon colon-at))
+		   (format:error "double `:' modifier"))
+	       (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
 	       (tilde-dispatch))
 	      ((#\')			; Character parameter
 	       (if modifier (format:error "misplaced modifier"))
@@ -782,29 +789,29 @@
 				      (loop j (+ j 1)))
 		       (loop i (+ j 1))))))))
 	obj))
-   
+
    ((boolean? obj) (if obj "#t" "#f"))
-   
+
    ((number? obj) (number->string obj))
 
-   ((symbol? obj) 
+   ((symbol? obj)
     (if format:symbol-case-conv
 	(format:symbol-case-conv (symbol->string obj))
 	(symbol->string obj)))
-   
+
    ((char? obj)
     (if slashify
 	(format:char->str obj)
 	(string obj)))
-   
+
    ((null? obj) "()")
 
    ((input-port? obj)
     (format:iobj->str obj))
-   
+
    ((output-port? obj)
     (format:iobj->str obj))
-     
+
    ((list? obj)
     (string-append "("
 		   (let loop ((obj-list obj))
@@ -822,16 +829,16 @@
 		   " . "
 		   (format:obj->str (cdr obj) #t)
 		   ")"))
-   
+
    ((vector? obj)
     (string-append "#" (format:obj->str (vector->list obj) #t)))
 
-   (else				; only objects with an #<...> 
+   (else				; only objects with an #<...>
     (format:iobj->str obj))))		; representation should fall in here
 
-;; format:iobj->str reveals the implementation dependent representation of 
+;; format:iobj->str reveals the implementation dependent representation of
 ;; #<...> objects with the use of display and call-with-output-string.
-;; If format:read-proof is set to #t the resulting string is additionally 
+;; If format:read-proof is set to #t the resulting string is additionally
 ;; set into string quotes.
 
 (define format:read-proof #f)
@@ -839,7 +846,7 @@
 (define (format:iobj->str iobj)
   (if (or format:read-proof
 	  format:iobj-case-conv)
-      (string-append 
+      (string-append
        (if format:read-proof "\"" "")
        (if format:iobj-case-conv
 	   (format:iobj-case-conv
@@ -881,7 +888,7 @@
 	(if par
 	    (if name
 		(if (< par 0)
-		    (format:error 
+		    (format:error
 		     "~s parameter must be a positive integer" name)
 		    par)
 		par)
@@ -927,7 +934,7 @@
 		  (if (and (memq modifier '(at colon-at)) (> number 0))
 		      (set! numlen (+ numlen 1)))
 		  (if (memq modifier '(colon colon-at))
-		      (set! numlen (+ (quotient (- numstr-len 
+		      (set! numlen (+ (quotient (- numstr-len
 						   (if (< number 0) 2 1))
 						commawidth)
 				      numlen)))
@@ -1071,7 +1078,8 @@
 	      (if (> ones 0)
 		  (cons #\-
 		    (string->list
-		      (list-ref format:cardinal-ones-list ones))))))))))
+		      (list-ref format:cardinal-ones-list ones)))
+		  '())))))))
 
 (define format:cardinal-thousand-block-list
   '("" " thousand" " million" " billion" " trillion" " quadrillion"
@@ -1173,7 +1181,7 @@
     (if digits
 
 	(begin				; fixed precision
-	  (format:parse-float 
+	  (format:parse-float
 	   (if (string? number) number (number->string number)) #t scale)
 	  (if (<= (- format:fn-len format:fn-dot) digits)
 	      (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
@@ -1230,7 +1238,7 @@
 	  (overch (format:par pars l 4 #f #f))
 	  (padch (format:par pars l 5 format:space-ch #f))
 	  (expch (format:par pars l 6 #f #f)))
-	 
+
     (if digits				; fixed precision
 
 	(let ((digits (if (> scale 0)
@@ -1238,7 +1246,7 @@
 			      (+ (- digits scale) 1)
 			      0)
 			  digits)))
-	  (format:parse-float 
+	  (format:parse-float
 	   (if (string? number) number (number->string number)) #f scale)
 	  (if (<= (- format:fn-len format:fn-dot) digits)
 	      (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
@@ -1250,11 +1258,11 @@
 		    (if (or (not format:fn-pos?) (eq? modifier 'at))
 			(set! numlen (+ numlen 1)))
 		    (if (and (= format:fn-dot 0) (> width (+ digits 1)))
-			(set! numlen (+ numlen 1)))	
+			(set! numlen (+ numlen 1)))
 		    (set! numlen
-			  (+ numlen 
+			  (+ numlen
 			     (if (and edigits (>= edigits format:en-len))
-				 edigits 
+				 edigits
 				 format:en-len)))
 		    (if (< numlen width)
 			(format:out-fill (- width numlen)
@@ -1283,7 +1291,7 @@
 		    (set! numlen
 			  (+ numlen
 			     (if (and edigits (>= edigits format:en-len))
-				 edigits 
+				 edigits
 				 format:en-len)))
 		    (if (< numlen width)
 			(format:out-fill (- width numlen)
@@ -1292,7 +1300,7 @@
 			(let ((f (- format:fn-len format:fn-dot))) ; fract len
 			  (if (> (- numlen f) width)
 			      (if overch ; numstr too big for required width
-				  (format:out-fill width 
+				  (format:out-fill width
 						   (integer->char overch))
 				  (begin
 				    (format:fn-out modifier #t)
@@ -1307,7 +1315,7 @@
 	      (begin
 		(format:fn-out modifier #t)
 		(format:en-out edigits expch))))))))
-	
+
 ;; format general flonums (~G)
 
 (define (format:out-general modifier number pars)
@@ -1429,7 +1437,7 @@
 
 	   (begin			; fixed format m.nnn or .nnn
 	     (if (and (> left-zeros 0) (> format:fn-dot 0))
-		 (if (> format:fn-dot left-zeros) 
+		 (if (> format:fn-dot left-zeros)
 		     (begin		; norm 0{0}nn.mm to nn.mm
 		       (format:fn-shiftleft left-zeros)
 		       (set! left-zeros 0)
@@ -1470,7 +1478,7 @@
 		     (set! format:fn-dot 1)))
 	     (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
 			       negexp))
-	     (cond 
+	     (cond
 	      (all-zeros?
 	       (format:en-set 0)
 	       (set! format:fn-dot 1))
@@ -1484,10 +1492,10 @@
 	       (set! format:fn-dot scale)))))
        #t)
 
-    ;; do body      
+    ;; do body
     (set! c (string-ref num-str i))	; parse the output of number->string
     (cond				; which can be any valid number
-     ((char-numeric? c)			; representation of R4RS except 
+     ((char-numeric? c)			; representation of R4RS except
       (if mantissa?			; complex numbers
 	  (begin
 	    (if (char=? c #\0)
@@ -1521,7 +1529,7 @@
       0
       (do ((i 0 (+ i 1))
 	   (n 0))
-	  ((= i format:en-len) 
+	  ((= i format:en-len)
 	   (if format:en-pos?
 	       n
 	       (- n)))
@@ -1581,14 +1589,14 @@
     (set! c (+ (- (char->integer (string-ref format:fn-str i))
 		  format:zero-ch) c))
     (string-set! format:fn-str i (integer->char
-				  (if (< c 10) 
+				  (if (< c 10)
 				      (+ c format:zero-ch)
 				      (+ (- c 10) format:zero-ch))))
     (set! c (if (< c 10) 0 1))))
 
 (define (format:fn-out modifier add-leading-zero?)
   (if format:fn-pos?
-      (if (eq? modifier 'at) 
+      (if (eq? modifier 'at)
 	  (format:out-char #\+))
       (format:out-char #\-))
   (if (= format:fn-dot 0)
@@ -1601,7 +1609,7 @@
 (define (format:en-out edigits expch)
   (format:out-char (if expch (integer->char expch) format:expch))
   (format:out-char (if format:en-pos? #\+ #\-))
-  (if edigits 
+  (if edigits
       (if (< format:en-len edigits)
 	  (format:out-fill (- edigits format:en-len) #\0)))
   (format:out-substr format:en-str 0 format:en-len))
@@ -1624,18 +1632,7 @@
 
 ;;; some global functions not found in SLIB
 
-;; string-index finds the index of the first occurence of the character `c'
-;; in the string `s'; it returns #f if there is no such character in `s'.
-
-(define (string-index s c)
-  (let ((slen-1 (- (string-length s) 1)))
-    (let loop ((i 0))
-      (cond
-       ((char=? c (string-ref s i)) i)
-       ((= i slen-1) #f)
-       (else (loop (+ i 1)))))))
-
-(define (string-capitalize-first str)	; "hello" -> "Hello"
+(define (format:string-capitalize-first str) ; "hello" -> "Hello"
   (let ((cap-str (string-copy str))	; "hELLO" -> "Hello"
 	(non-first-alpha #f)		; "*hello" -> "*Hello"
 	(str-len (string-length str)))	; "hello you" -> "Hello you"
@@ -1649,10 +1646,10 @@
 		  (set! non-first-alpha #t)
 		  (string-set! cap-str i (char-upcase c)))))))))
 
-(define (list-head l k)
+(define (format:list-head l k)
   (if (= k 0)
       '()
-      (cons (car l) (list-head (cdr l) (- k 1)))))
+      (cons (car l) (format:list-head (cdr l) (- k 1)))))
 
 
 ;; Aborts the program when a formatting error occures. This is a null