diff options
Diffstat (limited to 'printf.scm')
| -rw-r--r-- | printf.scm | 433 |
1 files changed, 332 insertions, 101 deletions
@@ -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"))) |