From fa3f23105ddcf07c5900de47f19af43d1db1b597 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:27 -0800
Subject: Import Upstream version 2c3

---
 printf.scm | 433 +++++++++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 332 insertions(+), 101 deletions(-)

(limited to 'printf.scm')

diff --git a/printf.scm b/printf.scm
index aefab5c..42341fc 100644
--- a/printf.scm
+++ b/printf.scm
@@ -19,14 +19,136 @@
 
 (require 'string-case)
 
-;;; Floating point is not handled yet.
+;; Parse the output of NUMBER->STRING.
+;; Returns a list: (sign-character digit-string exponent-integer)
+;; sign-char will be either #\+ or #\-, digit-string will always begin
+;; with a "0", after which a decimal point should be understood.
+(define (stdio:parse-float str)
+  (let ((n (string-length str)))
+    (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 (parse-error)))
+		    '(0))))
+	     (end
+	      (lambda (i)
+		(if (< i n) (parse-error) '())))
+	     (parse-error
+	      (lambda () #f)))
+      (let ((parsed
+	     (prefix 0
+		     (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))))))
 
-(define (stdio:iprintf out-proc format-string . args)
-  (define char-count 0)
-  (define (out c)
-    (cond ((char? c) (set! char-count (+ 1 char-count)))
-	  (else (set! char-count (+ (string-length c) char-count))))
-    (out-proc c) #t)
+;; STR is a digit string representing a floating point mantissa, STR must
+;; begin with "0", after which a decimal point is understood.
+;; The output is a digit string rounded to NDIGS digits after the decimal
+;; point implied between chars 0 and 1.
+;; If STRIP-0S is not #F then trailing zeros will be stripped from the result.
+;; In this case, STRIP-0S should be the minimum number of digits required
+;; after the implied decimal point.
+(define (stdio:round-string str ndigs strip-0s)
+  (let* ((n (- (string-length str) 1))
+	 (res
+	  (cond ((< ndigs 0) "")
+		((= n ndigs) str)
+		((< n ndigs)
+		 (if strip-0s str
+		     (string-append
+		      str (make-string (- ndigs n)
+				       (if (char-numeric? (string-ref str n))
+					   #\0 #\#)))))
+		(else
+		 (let ((res (substring str 0 (+ ndigs 1)))
+		       (dig (lambda (i)
+			      (let ((c (string-ref str i)))
+				(if (char-numeric? c)
+				    (string->number (string c))
+				    0)))))
+		   (let ((ldig (dig (+ 1 ndigs))))
+		     (if (or (> ldig 5)
+			     (and (= ldig 5)
+				  (let loop ((i (+ 2 ndigs)))
+				    (if (> i n) (odd? (dig ndigs))
+					(if (zero? (dig i))
+					    (loop (+ i 1))
+					    #t)))))
+			 (let inc! ((i ndigs))
+			   (let ((d (dig i)))
+			     (if (< d 9)
+				 (string-set! res i 
+					      (string-ref
+					       (number->string (+ d 1)) 0))
+				 (begin
+				   (string-set! res i #\0)
+				   (inc! (- i 1))))))))
+		   res)))))
+    (if strip-0s
+	(let loop ((i (- (string-length res) 1)))
+	  (if (or (<= i strip-0s)
+		  (not (char=? #\0 (string-ref res i))))
+	      (substring res 0 (+ i 1))
+	      (loop (- i 1))))
+	res)))
+
+
+(define (stdio:iprintf out format-string . args)
   (cond
    ((not (equal? "" format-string))
     (let ((pos -1)
@@ -53,14 +175,14 @@
 	 ((end-of-format?))
 	 ((eqv? #\\ fc);;Emulating C strings may not be a good idea.
 	  (must-advance)
-	  (case fc
-	    ((#\n #\N) (out #\newline))
-	    ((#\t #\T) (out slib:tab))
-	    ;;((#\r #\R) (out #\return))
-	    ((#\f #\F) (out slib:form-feed))
-	    ((#\newline) #f)
-	    (else (out fc)))
-	  (loop args))
+	  (and (case fc
+		 ((#\n #\N) (out #\newline))
+		 ((#\t #\T) (out slib:tab))
+		 ;;((#\r #\R) (out #\return))
+		 ((#\f #\F) (out slib:form-feed))
+		 ((#\newline) #t)
+		 (else (out fc)))
+	       (loop args)))
 	 ((eqv? #\% fc)
 	  (must-advance)
 	  (let ((left-adjust #f)	;-
@@ -85,45 +207,130 @@
 				      (string->number (string c)))))
 			 ((not (char-numeric? fc)) accum)
 		       (must-advance)))))))
+	    (define (pad pre . strs)
+	      (let loop ((len (string-length pre))
+			 (ss strs))
+		(cond ((>= len width) (apply string-append pre strs))
+		      ((null? ss)
+		       (cond (left-adjust
+			      (apply string-append
+				     pre
+				     (append strs
+					     (list (make-string 
+						    (- width len) #\space)))))
+			     (leading-0s
+			      (apply string-append
+				     pre
+				     (make-string (- width len) #\0)
+				     strs))
+			     (else
+			      (apply string-append
+				     (make-string (- width len) #\space)
+				     pre strs))))
+		      (else
+		       (loop (+ len (string-length (car ss))) (cdr ss))))))
 	    (define integer-convert
 	      (lambda (s radix)
+		(cond ((not (negative? precision))
+		       (set! leading-0s #f)
+		       (if (and (zero? precision)
+				(eqv? 0 s))
+			   (set! s ""))))
 		(set! s (cond ((symbol? s) (symbol->string s))
 			      ((number? s) (number->string s radix))
 			      ((or (not s) (null? s)) "0")
+			      ((string? s) s)
 			      (else "1")))
-		(cond ((not (negative? precision))
-		       (set! leading-0s #f)))
-		(let* ((pre
-			(cond ((equal? "" s) "")
-			      ((eqv? #\- (string-ref s 0))
-			       (set! s (substring s 1 (string-length s)))
-			       "-")
-			      (signed "+")
-			      (blank " ")
-			      ((equal? "" s) "")
-			      (alternate-form
-			       (case radix
-				 ((8) "0")
-				 ((16) "0x")
-				 (else "")))
-			      (else "")))
-		       (length-so-far (+ (string-length pre)
-					 (string-length s))))
-		  (cond ((<= width length-so-far)
-			 (string-append pre s))
-			(left-adjust
-			 (string-append
-			  pre s
-			  (make-string (- width length-so-far) #\ )))
-			(leading-0s
-			 (string-append
-			  pre (make-string (- width length-so-far) #\0)
-			  s))
+		(let ((pre (cond ((equal? "" s) "")
+				 ((eqv? #\- (string-ref s 0))
+				  (set! s (substring s 1 (string-length s)))
+				  "-")
+				 (signed "+")
+				 (blank " ")
+				 (alternate-form
+				  (case radix
+				    ((8) "0")
+				    ((16) "0x")
+				    (else "")))
+				 (else ""))))
+		  (pad pre
+		       (if (< (string-length s) precision)
+			   (make-string
+			    (- precision (string-length s)) #\0)
+			   "")
+		       s))))
+	    (define (float-convert num fc)
+	      (define (f digs exp strip-0s)
+		(let ((digs (stdio:round-string
+			     digs (+ exp precision) (and strip-0s exp))))
+		  (cond ((>= exp 0)
+			 (let* ((i0 (cond ((zero? exp) 0)
+					  ((char=? #\0 (string-ref digs 0)) 1)
+					  (else 0)))
+				(i1 (max 1 (+ 1 exp)))
+				(idigs (substring digs i0 i1))
+				(fdigs (substring digs i1
+						  (string-length digs))))
+			   (cons idigs
+				 (if (and (string=? fdigs "")
+					  (not alternate-form))
+				     '()
+				     (list "." fdigs)))))
+			((zero? precision)
+			 (list (if alternate-form "0." "0")))
+			((string=? digs "") (list "0"))
 			(else
-			 (string-append
-			  (make-string (- width length-so-far) #\ )
-			  pre s))))))
-
+			 (list "0."
+			       (make-string (min precision (- -1 exp)) #\0)
+			       digs)))))
+	      (define (e digs exp strip-0s)
+		(let* ((digs (stdio:round-string 
+			      digs (+ 1 precision) (and strip-0s 0)))
+		       (istrt (if (char=? #\0 (string-ref digs 0)) 1 0))
+		       (fdigs (substring 
+			       digs (+ 1 istrt) (string-length digs)))
+		       (exp (if (zero? istrt) exp (- exp 1))))
+		  (list
+		   (substring digs istrt (+ 1 istrt))
+		   (if (and (string=? fdigs "") (not alternate-form))
+		       "" ".")
+		   fdigs
+		   (if (char-upper-case? fc) "E" "e")
+		   (if (negative? exp) "-" "+")
+		   (if (< -10 exp 10) "0" "")
+		   (number->string (abs exp)))))
+	      (cond ((negative? precision)
+		     (set! precision 6))
+		    ((and (zero? precision)
+			  (char-ci=? fc #\g))
+		     (set! precision 1)))
+	      (let* ((str 
+		      (cond ((number? num)
+			     (number->string (exact->inexact num)))
+			    ((string? num) num)
+			    ((symbol? num) (symbol->string num))
+			    (else "???")))
+		     (parsed (stdio:parse-float str)))
+		(cond (parsed
+		       (apply
+			(lambda (sgn digs exp)
+			  (apply pad
+				 (if (char=? #\- sgn) "-"
+				     (if signed "+" (if blank " " "")))
+				 (case fc
+				   ((#\e #\E) (e digs exp #f))
+				   ((#\f #\F) (f digs exp #f))
+				   ((#\g #\G)
+				    (let ((strip-0s (not alternate-form)))
+				      (set! alternate-form #f)
+				      (cond ((< -4 exp (+ 1 precision))
+					     (set! precision (- precision exp))
+					     (f digs exp strip-0s))
+					    (else
+					     (set! precision (- precision 1))
+					     (e digs exp strip-0s))))))))
+			parsed))
+		      (else str))))
 	    (do ()
 		((case fc
 		   ((#\-) (set! left-adjust #t) #f)
@@ -151,8 +358,7 @@
 	    (case fc
 	      ;; only - is allowed between % and c
 	      ((#\c #\C)		; C is enhancement
-	       (out (string (car args)))
-	       (loop (cdr args)))
+	       (and (out (string (car args))) (loop (cdr args))))
 
 	      ;; only - flag, no type-modifiers
 	      ((#\s #\S)		; S is enhancement
@@ -163,25 +369,28 @@
 		 (cond ((not (or (negative? precision)
 				 (>= precision (string-length s))))
 			(set! s (substring s 0 precision))))
-		 (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
+			     (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)))))
 
 	      ;; SLIB extension
-	      ((#\a #\A)		;#\y #\Y are pretty-print
+	      ((#\a #\A)		;#\a #\A are pretty-print
 	       (require 'generic-write)
 	       (let ((os "") (pr precision))
 		 (generic-write
 		  (car args) (not alternate-form) #f
 		  (cond ((and left-adjust (negative? pr))
-			 out)
+			 (set! pr 0)
+			 (lambda (s)
+			   (set! pr (+ pr (string-length s)))
+			   (out s)))
 			(left-adjust
 			 (lambda (s)
 			   (define sl (- pr (string-length s)))
@@ -209,65 +418,87 @@
 				 (else (set! os (string-append os s))))
 			   (set! pr sl)
 			   (positive? sl)))))
-		 (cond (left-adjust
+		 (cond ((and left-adjust (negative? precision))
+			(cond
+			 ((> width pr) (out (make-string (- width pr) #\ )))))
+		       (left-adjust
 			(cond
 			 ((> width (- precision pr))
-			  (out (make-string (- width (- precision pr))
-					    #\ )))))
+			  (out (make-string (- width (- precision pr)) #\ )))))
 		       ((not os))
 		       ((<= width (string-length os)) (out os))
-		       (else
-			(out (make-string (- width (string-length os)) #\ ))
-			(out os))))
+		       (else (and (out (make-string
+					(- width (string-length os)) #\ ))
+				  (out os)))))
 	       (loop (cdr args)))
 	      ((#\d #\D #\i #\I #\u #\U)
-	       (out (integer-convert (car args) 10))
-	       (loop (cdr args)))
+	       (and (out (integer-convert (car args) 10)) (loop (cdr args))))
 	      ((#\o #\O)
-	       (out (integer-convert (car args) 8))
-	       (loop (cdr args)))
+	       (and (out (integer-convert (car args) 8)) (loop (cdr args))))
 	      ((#\x #\X)
-	       (out ((if (char-upper-case? fc) string-upcase string-downcase)
-		     (integer-convert (car args) 16)))
-	       (loop (cdr args)))
-	      ((#\%) (out #\%)
-		     (loop args))
+	       (and (out ((if (char-upper-case? fc)
+			      string-upcase string-downcase)
+			  (integer-convert (car args) 16)))
+		    (loop (cdr args))))
+	      ((#\b #\B)
+	       (and (out (integer-convert (car args) 2)) (loop (cdr args))))
+	      ((#\%) (and (out #\%) (loop args)))
+	      ((#\f #\F #\e #\E #\g #\G)
+	       (and (out (float-convert (car args) fc)) (loop (cdr args))))
 	      (else
 	       (cond ((end-of-format?) (incomplete))
-		     (else (out #\%) (out fc) (out #\?)
-			   (loop args)))))))
-	 (else (out fc)
-	       (loop args)))))))
-  char-count)				; return number of characters output.
-
-(define (stdio:printf format . args)
-  (apply stdio:iprintf display format args))
+		     (else (and (out #\%) (out fc) (out #\?) (loop args))))))))
+	 (else (and (out fc) (loop args)))))))))
 
 (define (stdio:fprintf port format . args)
-  (if (equal? port (current-output-port))
-      (apply stdio:iprintf display format args)
-      (apply stdio:iprintf (lambda (x) (display x port)) format args)))
+  (let ((cnt 0))
+    (apply stdio:iprintf
+	   (lambda (x)
+	     (cond ((string? x)
+		    (set! cnt (+ (string-length x) cnt)) (display x port) #t)
+		   (else (set! cnt (+ 1 cnt)) (display x port) #t)))
+	   format args)
+    cnt))
 
-(define (stdio:sprintf s format . args)
-  (let ((p 0) (end (string-length s)))
+(define (stdio:printf format . args)
+  (apply stdio:fprintf (current-output-port) format args))
+
+(define (stdio:sprintf str format . args)
+  (let* ((cnt 0)
+	 (s (cond ((string? str) str)
+		  ((number? str) (make-string str))
+		  ((not str) (make-string 100))
+		  (else (slib:error 'sprintf "first argument not understood"
+				    str))))
+	 (end (string-length s)))
     (apply stdio:iprintf
 	   (lambda (x)
 	     (cond ((string? x)
-		    (do ((i 0 (+ i 1)))
-			((>= i (min (string-length x) end)))
-		      (string-set! s p (string-ref x i))
-		      (set! p (+ p 1))))
-		   ((>= p end))
-		   ((char? x)
-		    (string-set! s p x)
-		    (set! p (+ p 1)))
-		   (else
-		    (string-set! s p #\?)
-		    (set! p (+ p 1)))))
+		    (if (or str (>= (- end cnt) (string-length x)))
+			(do ((lend (min (string-length x) (- end cnt)))
+			     (i 0 (+ i 1)))
+			    ((>= i lend))
+			  (string-set! s cnt (string-ref x i))
+			  (set! cnt (+ cnt 1)))
+			(let ()
+			  (set! s (string-append (substring s 0 cnt) x))
+			  (set! cnt (string-length s))
+			  (set! end cnt))))
+		   ((and str (>= cnt end)))
+		   (else (cond ((and (not str) (>= cnt end))
+				(set! s (string-append s (make-string 100)))
+				(set! end (string-length s))))
+			 (string-set! s cnt (if (char? x) x #\?))
+			 (set! cnt (+ cnt 1))))
+	     (not (and str (>= cnt end))))
 	   format
 	   args)
-    p))
+    (cond ((string? str) cnt)
+	  ((eqv? end cnt) s)
+	  (else (substring s 0 cnt)))))
 
 (define printf stdio:printf)
 (define fprintf stdio:fprintf)
 (define sprintf stdio:sprintf)
+
+;;(do ((i 0 (+ 1 i))) ((> i 50)) (printf "%s\n" (sprintf i "%#-13a:%#13a:%-13.8a:" "123456789" "123456789" "123456789")))
-- 
cgit v1.2.3