summaryrefslogtreecommitdiffstats
path: root/printf.scm
diff options
context:
space:
mode:
Diffstat (limited to 'printf.scm')
-rw-r--r--printf.scm366
1 files changed, 190 insertions, 176 deletions
diff --git a/printf.scm b/printf.scm
index da7178c..d17cf79 100644
--- a/printf.scm
+++ b/printf.scm
@@ -1,9 +1,9 @@
;;;; "printf.scm" Implementation of standard C functions for Scheme
-;;; Copyright (C) 1991-1993, 1996 Aubrey Jaffer.
+;;; Copyright (C) 1991-1993, 1996, 1999-2001 Aubrey Jaffer and Radey Shouman.
;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
@@ -19,117 +19,112 @@
(require 'string-case)
-;; Parse the output of NUMBER->STRING.
-;; Returns a list: (sign-character digit-string exponent-integer)
+;; Determine the case of digits > 9. We assume this to be constant.
+(define stdio:hex-upper-case? (string=? "-F" (number->string -15 16)))
+
+;; Parse the output of NUMBER->STRING and pass the results to PROC.
+;; PROC takes (SIGN-CHARACTER DIGIT-STRING EXPONENT-INTEGER . IMAGPART)
;; 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))
- (iend 0))
- (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 (end! i)
- '(0)))
- (begin (end! i)
- '(0)))))
- (end!
- (lambda (i)
- (set! iend i)
- '()))
- (real
- (lambda (i)
- (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 ((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))))))
+;; If STR denotes a number with imaginary part not exactly zero,
+;; 3 additional elements for the imaginary part are passed.
+;; If STR cannot be parsed, return #F without calling PROC.
+(define (stdio:parse-float str proc)
+ (let ((n (string-length str)))
+ (define (parse-error) #f)
+ (define (prefix i cont)
+ (if (and (< i (- n 1))
+ (char=? #\# (string-ref str i)))
+ (case (string-ref str (+ i 1))
+ ((#\d #\i #\e) (prefix (+ i 2) cont))
+ ((#\.) (cont i))
+ (else (parse-error)))
+ (cont i)))
+ (define (sign i cont)
+ (if (< i n)
+ (let ((c (string-ref str i)))
+ (case c
+ ((#\- #\+) (cont (+ i 1) c))
+ (else (cont i #\+))))))
+ (define (digits i cont)
+ (do ((j i (+ j 1)))
+ ((or (>= j n)
+ (not (or (char-numeric? (string-ref str j))
+ (char=? #\# (string-ref str j)))))
+ (cont j (if (= i j) "0" (substring str i j))))))
+ (define (point i cont)
+ (if (and (< i n)
+ (char=? #\. (string-ref str i)))
+ (cont (+ i 1))
+ (cont i)))
+ (define (exp i cont)
+ (cond ((>= i n) (cont i 0))
+ ((memv (string-ref str i)
+ '(#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L))
+ (sign (+ i 1)
+ (lambda (i sgn)
+ (digits i
+ (lambda (i digs)
+ (cont i
+ (if (char=? #\- sgn)
+ (- (string->number digs))
+ (string->number digs))))))))
+ (else (cont i 0))))
+ (define (real i cont)
+ (prefix
+ i
+ (lambda (i)
+ (sign
+ i
+ (lambda (i sgn)
+ (digits
+ i
+ (lambda (i idigs)
+ (point
+ i
+ (lambda (i)
+ (digits
+ i
+ (lambda (i fdigs)
+ (exp i
+ (lambda (i ex)
+ (let* ((digs (string-append "0" idigs fdigs))
+ (ndigs (string-length digs)))
+ (let loop ((j 1)
+ (ex (+ ex (string-length idigs))))
+ (cond ((>= j ndigs) ;; Zero
+ (cont i sgn "0" 1))
+ ((char=? #\0 (string-ref digs j))
+ (loop (+ j 1) (- ex 1)))
+ (else
+ (cont i sgn
+ (substring digs (- j 1) ndigs)
+ ex))))))))))))))))))
+ (real 0
+ (lambda (i sgn digs ex)
+ (cond
+ ((= i n) (proc sgn digs ex))
+ ((memv (string-ref str i) '(#\+ #\-))
+ (real i
+ (lambda (j im-sgn im-digs im-ex)
+ (if (and (= j (- n 1))
+ (char-ci=? #\i (string-ref str j)))
+ (proc sgn digs ex im-sgn im-digs im-ex)
+ (parse-error)))))
+ ((eqv? (string-ref str i) #\@)
+ ;; Polar form: No point in parsing the angle ourselves,
+ ;; since some transcendental approximation is unavoidable.
+ (let ((num (string->number str)))
+ (if num
+ (stdio:parse-float
+ (number->string (real-part num))
+ (lambda (sgn digs ex)
+ (stdio:parse-float
+ (number->string (imag-part num))
+ (lambda (im-sgn im-digs im-ex)
+ (proc sgn digs ex im-sgn im-digs im-ex)))))
+ (parse-error))))
+ (else #f))))))
;; STR is a digit string representing a floating point mantissa, STR must
;; begin with "0", after which a decimal point is understood.
@@ -144,13 +139,14 @@
(cond ((< ndigs 0) "")
((= n ndigs) str)
((< n ndigs)
- (let ((zeropad (make-string
- (max 0 (- (or strip-0s ndigs) n))
- (if (char-numeric? (string-ref str n))
- #\0 #\#))))
- (if (zero? (string-length zeropad))
+ (let ((padlen (max 0 (- (or strip-0s ndigs) n))))
+ (if (zero? padlen)
str
- (string-append str zeropad))))
+ (string-append str
+ (make-string padlen
+ (if (char-numeric?
+ (string-ref str n))
+ #\0 #\#))))))
(else
(let ((res (substring str 0 (+ ndigs 1)))
(dig (lambda (i)
@@ -162,7 +158,8 @@
(if (or (> ldig 5)
(and (= ldig 5)
(let loop ((i (+ 2 ndigs)))
- (if (> i n) (odd? (dig ndigs))
+ (if (> i n)
+ (odd? (dig ndigs))
(if (zero? (dig i))
(loop (+ i 1))
#t)))))
@@ -208,6 +205,12 @@
(slib:error 'printf "wrong number of arguments"
(length args)
format-string))
+ (define (out* strs)
+ (if (string? strs) (out strs)
+ (let out-loop ((strs strs))
+ (or (null? strs)
+ (and (out (car strs))
+ (out-loop (cdr strs)))))))
(let loop ((args args))
(advance)
@@ -252,27 +255,24 @@
(define (pad pre . strs)
(let loop ((len (string-length pre))
(ss strs))
- (cond ((>= len width) (apply string-append pre strs))
+ (cond ((>= len width) (cons pre strs))
((null? ss)
(cond (left-adjust
- (apply string-append
- pre
- (append strs
- (list (make-string
- (- width len) #\space)))))
+ (cons pre
+ (append strs
+ (list (make-string
+ (- width len) #\space)))))
(leading-0s
- (apply string-append
- pre
- (make-string (- width len) #\0)
- strs))
+ (cons pre
+ (cons (make-string (- width len) #\0)
+ strs)))
(else
- (apply string-append
- (make-string (- width len) #\space)
- pre strs))))
+ (cons (make-string (- width len) #\space)
+ (cons pre strs)))))
(else
(loop (+ len (string-length (car ss))) (cdr ss))))))
(define integer-convert
- (lambda (s radix)
+ (lambda (s radix fixcase)
(cond ((not (negative? precision))
(set! leading-0s #f)
(if (and (zero? precision)
@@ -283,6 +283,7 @@
((or (not s) (null? s)) "0")
((string? s) s)
(else "1")))
+ (if fixcase (set! s (fixcase s)))
(let ((pre (cond ((equal? "" s) "")
((eqv? #\- (string-ref s 0))
(set! s (substring s 1 (string-length s)))
@@ -380,26 +381,28 @@
(number->string (exact->inexact num)))
((string? num) num)
((symbol? num) (symbol->string num))
- (else "???")))
- (parsed (stdio:parse-float str)))
- (letrec ((format-real
- (lambda (signed? sgn digs exp . rest)
- (if (null? rest)
- (cons
- (if (char=? #\- sgn) "-"
- (if signed? "+" (if blank " " "")))
- (case fc
- ((#\e #\E) (e digs exp #f))
- ((#\f #\F) (f digs exp #f))
- ((#\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 "???")))))
+ (else "???"))))
+ (define (format-real signed? sgn digs exp . rest)
+ (if (null? rest)
+ (cons
+ (if (char=? #\- sgn) "-"
+ (if signed? "+" (if blank " " "")))
+ (case fc
+ ((#\e #\E) (e digs exp #f))
+ ((#\f #\F) (f digs exp #f))
+ ((#\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"))))
+ (or (stdio:parse-float str
+ (lambda (sgn digs expon . imag)
+ (apply pad
+ (apply format-real
+ signed
+ sgn digs expon imag))))
+ (pad "???"))))
(do ()
((case fc
((#\-) (set! left-adjust #t) #f)
@@ -432,7 +435,7 @@
(wna)))
(case fc
- ;; only - is allowed between % and c
+ ;; only - is allowed between % and c
((#\c #\C) ; C is enhancement
(and (out (string (car args))) (loop (cdr args))))
@@ -445,18 +448,20 @@
(cond ((not (or (negative? precision)
(>= precision (string-length s))))
(set! s (substring s 0 precision))))
- (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)))))
+ (and
+ (out* (cond
+ ((<= width (string-length s)) s)
+ (left-adjust
+ (list
+ s (make-string (- width (string-length s)) #\ )))
+ (else
+ (list
+ (make-string (- width (string-length s))
+ (if leading-0s #\0 #\ ))
+ s))))
+ (loop (cdr args)))))
- ;; SLIB extension
+ ;; SLIB extension
((#\a #\A) ;#\a #\A are pretty-print
(require 'generic-write)
(let ((os "") (pr precision))
@@ -508,22 +513,31 @@
(out os)))))
(loop (cdr args)))
((#\d #\D #\i #\I #\u #\U)
- (and (out (integer-convert (car args) 10)) (loop (cdr args))))
+ (and (out* (integer-convert (car args) 10 #f))
+ (loop (cdr args))))
((#\o #\O)
- (and (out (integer-convert (car args) 8)) (loop (cdr args))))
- ((#\x #\X)
- (and (out ((if (char-upper-case? fc)
- string-upcase string-downcase)
- (integer-convert (car args) 16)))
+ (and (out* (integer-convert (car args) 8 #f))
+ (loop (cdr args))))
+ ((#\x)
+ (and (out* (integer-convert
+ (car args) 16
+ (if stdio:hex-upper-case? string-downcase #f)))
+ (loop (cdr args))))
+ ((#\X)
+ (and (out* (integer-convert
+ (car args) 16
+ (if stdio:hex-upper-case? #f string-upcase)))
(loop (cdr args))))
((#\b #\B)
- (and (out (integer-convert (car args) 2)) (loop (cdr args))))
+ (and (out* (integer-convert (car args) 2 #f))
+ (loop (cdr args))))
((#\%) (and (out #\%) (loop args)))
((#\f #\F #\e #\E #\g #\G #\k #\K)
- (and (out (float-convert (car args) fc)) (loop (cdr args))))
+ (and (out* (float-convert (car args) fc)) (loop (cdr args))))
(else
- (cond ((end-of-format?) (incomplete))
- (else (and (out #\%) (out fc) (out #\?) (loop args))))))))
+ (cond
+ ((end-of-format?) (incomplete))
+ (else (and (out #\%) (out fc) (out #\?) (loop args))))))))
(else (and (out fc) (loop args)))))))))
(define (stdio:fprintf port format . args)