; Version 3.0
(define-module (ice-9 format)
- :autoload (ice-9 pretty-print) (pretty-print))
-
-(begin-deprecated
- ;; So that `export' below will not accidentally re-export the
- ;; `format' of the `(guile)' module.
- (define format #f))
-
-(export format
- format:symbol-case-conv
- format:iobj-case-conv
- format:expch)
+ :use-module (ice-9 and-let-star)
+ :use-module (ice-9 threads)
+ :autoload (ice-9 pretty-print) (pretty-print)
+ :replace (format)
+ :export (format:symbol-case-conv
+ format:iobj-case-conv
+ format:expch))
;;; Configuration ------------------------------------------------------------
(do ((k i (+ k 1)))
((= k n))
(write-char (string-ref str k) format:port))
- (set! format:output-col (+ format:output-col n)))
+ (set! format:output-col (+ format:output-col (- n i))))
;(define (format:out-fill n ch) ; this allocates a new string
; (format:out-str (make-string n ch)))
(set! format:port port) ; global port for output routines
(set! format:case-conversion #f) ; modifier case conversion procedure
(set! format:flush-output #f) ; ~! reset
+ (and-let* ((col (port-column port))) ; get current column from port
+ (set! format:output-col col))
(let ((arg-pos (format:format-work fmt args))
(arg-len (length args)))
(cond
(list-ref format:ordinal-ones-list ones))))
))))))))
+;; format inf and nan.
+
+(define (format:out-inf-nan number width digits edigits overch padch)
+ ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
+ ;; "+nan.0", suitably justified in their field. We insist on
+ ;; printing this exact form so that the numbers can be read back in.
+
+ (let* ((str (number->string number))
+ (len (string-length str))
+ (dot (string-index str #\.))
+ (digits (+ (or digits 0)
+ (if edigits (+ edigits 2) 0))))
+ (if (and width overch (< width len))
+ (format:out-fill width (integer->char overch))
+ (let* ((leftpad (if width
+ (max (- width (max len (+ dot 1 digits))) 0)
+ 0))
+ (rightpad (if width
+ (max (- width leftpad len) 0)
+ 0))
+ (padch (integer->char (or padch format:space-ch))))
+ (format:out-fill leftpad padch)
+ (format:out-str str)
+ (format:out-fill rightpad padch)))))
+
;; format fixed flonums (~F)
(define (format:out-fixed modifier number pars)
(overch (format:par pars l 3 #f #f))
(padch (format:par pars l 4 format:space-ch #f)))
- (if digits
+ (cond
+ ((or (inf? number) (nan? number))
+ (format:out-inf-nan number width digits #f overch padch))
+
+ (digits
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t scale)
+ (if (<= (- format:fn-len format:fn-dot) digits)
+ (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+ (format:fn-round digits))
+ (if width
+ (let ((numlen (+ format:fn-len 1)))
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (and (= format:fn-dot 0) (> width (+ digits 1)))
+ (set! numlen (+ numlen 1)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen) (integer->char padch)))
+ (if (and overch (> numlen width))
+ (format:out-fill width (integer->char overch))
+ (format:fn-out modifier (> width (+ digits 1)))))
+ (format:fn-out modifier #t)))
- (begin ; fixed precision
- (format:parse-float
- (if (string? number) number (number->string number)) #t scale)
- (if (<= (- format:fn-len format:fn-dot) digits)
- (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
- (format:fn-round digits))
- (if width
- (let ((numlen (+ format:fn-len 1)))
- (if (or (not format:fn-pos?) (eq? modifier 'at))
- (set! numlen (+ numlen 1)))
- (if (and (= format:fn-dot 0) (> width (+ digits 1)))
- (set! numlen (+ numlen 1)))
- (if (< numlen width)
- (format:out-fill (- width numlen) (integer->char padch)))
- (if (and overch (> numlen width))
- (format:out-fill width (integer->char overch))
- (format:fn-out modifier (> width (+ digits 1)))))
- (format:fn-out modifier #t)))
-
- (begin ; free precision
- (format:parse-float
- (if (string? number) number (number->string number)) #t scale)
- (format:fn-strip)
- (if width
- (let ((numlen (+ format:fn-len 1)))
- (if (or (not format:fn-pos?) (eq? modifier 'at))
- (set! numlen (+ numlen 1)))
- (if (= format:fn-dot 0)
- (set! numlen (+ numlen 1)))
- (if (< numlen width)
- (format:out-fill (- width numlen) (integer->char padch)))
- (if (> numlen width) ; adjust precision if possible
- (let ((dot-index (- numlen
- (- format:fn-len format:fn-dot))))
- (if (> dot-index width)
- (if overch ; numstr too big for required width
- (format:out-fill width (integer->char overch))
- (format:fn-out modifier #t))
- (begin
- (format:fn-round (- width dot-index))
- (format:fn-out modifier #t))))
- (format:fn-out modifier #t)))
- (format:fn-out modifier #t)))))))
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t scale)
+ (format:fn-strip)
+ (if width
+ (let ((numlen (+ format:fn-len 1)))
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (= format:fn-dot 0)
+ (set! numlen (+ numlen 1)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen) (integer->char padch)))
+ (if (> numlen width) ; adjust precision if possible
+ (let ((dot-index (- numlen
+ (- format:fn-len format:fn-dot))))
+ (if (> dot-index width)
+ (if overch ; numstr too big for required width
+ (format:out-fill width (integer->char overch))
+ (format:fn-out modifier #t))
+ (begin
+ (format:fn-round (- width dot-index))
+ (format:fn-out modifier #t))))
+ (format:fn-out modifier #t)))
+ (format:fn-out modifier #t)))))))
;; format exponential flonums (~E)
(overch (format:par pars l 4 #f #f))
(padch (format:par pars l 5 format:space-ch #f))
(expch (format:par pars l 6 #f #f)))
-
- (if digits ; fixed precision
+
+ (cond
+ ((or (inf? number) (nan? number))
+ (format:out-inf-nan number width digits edigits overch padch))
+
+ (digits ; fixed precision
(let ((digits (if (> scale 0)
(if (< scale (+ digits 2))
(format:en-out edigits expch)))))
(begin
(format:fn-out modifier #t)
- (format:en-out edigits expch))))
+ (format:en-out edigits expch)))))
- (begin ; free precision
- (format:parse-float
- (if (string? number) number (number->string number)) #f scale)
- (format:fn-strip)
- (if width
- (if (and edigits overch (> format:en-len edigits))
- (format:out-fill width (integer->char overch))
- (let ((numlen (+ format:fn-len 3))) ; .E+
- (if (or (not format:fn-pos?) (eq? modifier 'at))
- (set! numlen (+ numlen 1)))
- (if (= format:fn-dot 0)
- (set! numlen (+ numlen 1)))
- (set! numlen
- (+ numlen
- (if (and edigits (>= edigits format:en-len))
- edigits
- format:en-len)))
- (if (< numlen width)
- (format:out-fill (- width numlen)
- (integer->char padch)))
- (if (> numlen width) ; adjust precision if possible
- (let ((f (- format:fn-len format:fn-dot))) ; fract len
- (if (> (- numlen f) width)
- (if overch ; numstr too big for required width
- (format:out-fill width
- (integer->char overch))
- (begin
- (format:fn-out modifier #t)
- (format:en-out edigits expch)))
- (begin
- (format:fn-round (+ (- f numlen) width))
- (format:fn-out modifier #t)
- (format:en-out edigits expch))))
- (begin
- (format:fn-out modifier #t)
- (format:en-out edigits expch)))))
- (begin
- (format:fn-out modifier #t)
- (format:en-out edigits expch))))))))
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #f scale)
+ (format:fn-strip)
+ (if width
+ (if (and edigits overch (> format:en-len edigits))
+ (format:out-fill width (integer->char overch))
+ (let ((numlen (+ format:fn-len 3))) ; .E+
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (= format:fn-dot 0)
+ (set! numlen (+ numlen 1)))
+ (set! numlen
+ (+ numlen
+ (if (and edigits (>= edigits format:en-len))
+ edigits
+ format:en-len)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen)
+ (integer->char padch)))
+ (if (> numlen width) ; adjust precision if possible
+ (let ((f (- format:fn-len format:fn-dot))) ; fract len
+ (if (> (- numlen f) width)
+ (if overch ; numstr too big for required width
+ (format:out-fill width
+ (integer->char overch))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch)))
+ (begin
+ (format:fn-round (+ (- f numlen) width))
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch))))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch)))))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch))))))))
;; format general flonums (~G)
(edigits (if (> l 2) (list-ref pars 2) #f))
(overch (if (> l 4) (list-ref pars 4) #f))
(padch (if (> l 5) (list-ref pars 5) #f)))
- (format:parse-float
- (if (string? number) number (number->string number)) #t 0)
- (format:fn-strip)
- (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
- (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
- (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ?
- (- (format:fn-zlead))
- format:fn-dot))
- (d (if digits
- digits
- (max format:fn-len (min n 7)))) ; q = format:fn-len
- (dd (- d n)))
- (if (<= 0 dd d)
- (begin
- (format:out-fixed modifier number (list ww dd #f overch padch))
- (format:out-fill ee #\space)) ;~@T not implemented yet
- (format:out-expon modifier number pars))))))
+ (cond
+ ((or (inf? number) (nan? number))
+ ;; FIXME: this isn't right.
+ (format:out-inf-nan number width digits edigits overch padch))
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t 0)
+ (format:fn-strip)
+ (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
+ (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
+ (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ?
+ (- (format:fn-zlead))
+ format:fn-dot))
+ (d (if digits
+ digits
+ (max format:fn-len (min n 7)))) ; q = format:fn-len
+ (dd (- d n)))
+ (if (<= 0 dd d)
+ (begin
+ (format:out-fixed modifier number (list ww dd #f overch padch))
+ (format:out-fill ee #\space)) ;~@T not implemented yet
+ (format:out-expon modifier number pars))))))))
;; format dollar flonums (~$)
; the flonum buffers
-(define format:fn-max 200) ; max. number of number digits
+(define format:fn-max 400) ; max. number of number digits
(define format:fn-str (make-string format:fn-max)) ; number buffer
(define format:fn-len 0) ; digit length of number
(define format:fn-dot #f) ; dot position of number
;;; some global functions not found in SLIB
-;; string-index finds the index of the first occurence of the character `c'
-;; in the string `s'; it returns #f if there is no such character in `s'.
-
-(define (string-index s c)
- (let ((slen-1 (- (string-length s) 1)))
- (let loop ((i 0))
- (cond
- ((char=? c (string-ref s i)) i)
- ((= i slen-1) #f)
- (else (loop (+ i 1)))))))
-
(define (string-capitalize-first str) ; "hello" -> "Hello"
(let ((cap-str (string-copy str)) ; "hELLO" -> "Hello"
(non-first-alpha #f) ; "*hello" -> "*Hello"
(set! non-first-alpha #t)
(string-set! cap-str i (char-upcase c)))))))))
-(define (list-head l k)
- (if (= k 0)
- '()
- (cons (car l) (list-head (cdr l) (- k 1)))))
-
-
;; Aborts the program when a formatting error occures. This is a null
;; argument closure to jump to the interpreters toplevel continuation.
(define format:abort (lambda () (error "error in format")))
-(define format format:format)
+(define (format . args) (monitor (apply format:format args)))
+
;; Thanks to Shuji Narazaki
(module-set! the-root-module 'format format)
HCoop / bpt / guile.git / blobdiff