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

---
 printf.scm | 198 ++++++++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 137 insertions(+), 61 deletions(-)

(limited to 'printf.scm')

diff --git a/printf.scm b/printf.scm
index 42341fc..da7178c 100644
--- a/printf.scm
+++ b/printf.scm
@@ -21,10 +21,13 @@
 
 ;; 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
+;; 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)))
+  (let ((n (string-length str))
+	(iend 0))
     (letrec ((prefix
 	      (lambda (i rest)
 		(if (and (< i (- n 1))
@@ -41,7 +44,7 @@
 		      (case c
 			((#\- #\+) (cons c (rest (+ i 1))))
 			(else (cons #\+ (rest i))))))))
-	     (digits 
+	     (digits
 	      (lambda (i rest)
 		(do ((j i (+ j 1)))
 		    ((or (>= j n)
@@ -56,45 +59,77 @@
 			 (char=? #\. (string-ref str i)))
 		    (rest (+ i 1))
 		    (rest i))))
-	     (exp 
+	     (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)))))
+		       (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
+		      (else (end! i)
+			    '(0)))
+		    (begin (end! i)
+			   '(0)))))
+	     (end!
+	      (lambda (i)
+		(set! iend i)
+		'()))
+	     (real
 	      (lambda (i)
-		(if (< i n) (parse-error) '())))
+		(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 ((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))))))
+      (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))))))
 
 ;; STR is a digit string representing a floating point mantissa, STR must
 ;; begin with "0", after which a decimal point is understood.
@@ -109,11 +144,13 @@
 	  (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 #\#)))))
+		 (let ((zeropad (make-string
+				 (max 0 (- (or strip-0s ndigs) n))
+				 (if (char-numeric? (string-ref str n))
+				     #\0 #\#))))
+		   (if (zero? (string-length zeropad))
+		       str
+		       (string-append str zeropad))))
 		(else
 		 (let ((res (substring str 0 (+ ndigs 1)))
 		       (dig (lambda (i)
@@ -132,7 +169,7 @@
 			 (let inc! ((i ndigs))
 			   (let ((d (dig i)))
 			     (if (< d 9)
-				 (string-set! res i 
+				 (string-set! res i
 					      (string-ref
 					       (number->string (+ d 1)) 0))
 				 (begin
@@ -147,7 +184,6 @@
 	      (loop (- i 1))))
 	res)))
 
-
 (define (stdio:iprintf out format-string . args)
   (cond
    ((not (equal? "" format-string))
@@ -168,11 +204,17 @@
       (define (incomplete)
 	(slib:error 'printf "conversion specification incomplete"
 		    format-string))
+      (define (wna)
+	(slib:error 'printf "wrong number of arguments"
+		    (length args)
+		    format-string))
 
       (let loop ((args args))
 	(advance)
 	(cond
-	 ((end-of-format?))
+	 ((end-of-format?)
+	  ;;(or (null? args) (wna))	;Extra arguments are *not* a bug.
+	  )
 	 ((eqv? #\\ fc);;Emulating C strings may not be a good idea.
 	  (must-advance)
 	  (and (case fc
@@ -216,7 +258,7 @@
 			      (apply string-append
 				     pre
 				     (append strs
-					     (list (make-string 
+					     (list (make-string
 						    (- width len) #\space)))))
 			     (leading-0s
 			      (apply string-append
@@ -278,16 +320,16 @@
 				     (list "." fdigs)))))
 			((zero? precision)
 			 (list (if alternate-form "0." "0")))
-			((string=? digs "") (list "0"))
+			((and strip-0s (string=? digs "") (list "0")))
 			(else
 			 (list "0."
 			       (make-string (min precision (- -1 exp)) #\0)
 			       digs)))))
 	      (define (e digs exp strip-0s)
-		(let* ((digs (stdio:round-string 
+		(let* ((digs (stdio:round-string
 			      digs (+ 1 precision) (and strip-0s 0)))
 		       (istrt (if (char=? #\0 (string-ref digs 0)) 1 0))
-		       (fdigs (substring 
+		       (fdigs (substring
 			       digs (+ 1 istrt) (string-length digs)))
 		       (exp (if (zero? istrt) exp (- exp 1))))
 		  (list
@@ -299,38 +341,65 @@
 		   (if (negative? exp) "-" "+")
 		   (if (< -10 exp 10) "0" "")
 		   (number->string (abs exp)))))
+	      (define (g digs exp)
+		(let ((strip-0s (not alternate-form)))
+		  (set! alternate-form #f)
+		  (cond ((<= (- 1 precision) exp precision)
+			 (set! precision (- precision exp))
+			 (f digs exp strip-0s))
+			(else
+			 (set! precision (- precision 1))
+			 (e digs exp strip-0s)))))
+	      (define (k digs exp sep)
+		(let* ((units '#("y" "z" "a" "f" "p" "n" "u" "m" ""
+				 "k" "M" "G" "T" "P" "E" "Z" "Y"))
+		       (base 8)		;index of ""
+		       (uind (let ((i (if (negative? exp)
+					  (quotient (- exp 3) 3)
+					  (quotient (- exp 1) 3))))
+			       (and
+				(< -1 (+ i base) (vector-length units))
+				i))))
+		  (cond (uind
+			 (set! exp (- exp (* 3 uind)))
+			 (set! precision (max 0 (- precision exp)))
+			 (append
+			  (f digs exp #f)
+			  (list sep
+				(vector-ref units (+ uind base)))))
+			(else
+			 (g digs exp)))))
+
 	      (cond ((negative? precision)
 		     (set! precision 6))
 		    ((and (zero? precision)
 			  (char-ci=? fc #\g))
 		     (set! precision 1)))
-	      (let* ((str 
+	      (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
+		(letrec ((format-real
+			  (lambda (signed? sgn digs exp . rest)
+			    (if (null? rest)
+				(cons
 				 (if (char=? #\- sgn) "-"
-				     (if signed "+" (if blank " " "")))
+				     (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))))
+				   ((#\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 "???")))))
 	    (do ()
 		((case fc
 		   ((#\-) (set! left-adjust #t) #f)
@@ -355,6 +424,13 @@
 	       (set! type-modifier fc)
 	       (must-advance)))
 
+	    ;;At this point fc completely determines the format to use.
+	    (if (null? args)
+		(if (memv (char-downcase fc)
+			  '(#\c #\s #\a #\d #\i #\u #\o #\x #\b
+			    #\f #\e #\g #\k))
+		    (wna)))
+
 	    (case fc
 	      ;; only - is allowed between % and c
 	      ((#\c #\C)		; C is enhancement
@@ -443,7 +519,7 @@
 	      ((#\b #\B)
 	       (and (out (integer-convert (car args) 2)) (loop (cdr args))))
 	      ((#\%) (and (out #\%) (loop args)))
-	      ((#\f #\F #\e #\E #\g #\G)
+	      ((#\f #\F #\e #\E #\g #\G #\k #\K)
 	       (and (out (float-convert (car args) fc)) (loop (cdr args))))
 	      (else
 	       (cond ((end-of-format?) (incomplete))
-- 
cgit v1.2.3