summaryrefslogtreecommitdiffstats
path: root/printf.scm
diff options
context:
space:
mode:
Diffstat (limited to 'printf.scm')
-rw-r--r--printf.scm433
1 files changed, 332 insertions, 101 deletions
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")))