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