summaryrefslogtreecommitdiffstats
path: root/printf.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commitbd9733926076885e3417b74de76e4c9c7bc56254 (patch)
tree2c99dced547d48407ad44cb0e45e31bb4d02ce43 /printf.scm
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-bd9733926076885e3417b74de76e4c9c7bc56254.tar.gz
slib-bd9733926076885e3417b74de76e4c9c7bc56254.zip
Import Upstream version 2c7upstream/2c7
Diffstat (limited to 'printf.scm')
-rw-r--r--printf.scm198
1 files changed, 137 insertions, 61 deletions
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))