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