;
; Version 3.0
-(define-module (ice-9 format))
-(export format
- format:symbol-case-conv
- format:iobj-case-conv
- format:expch)
+(define-module (ice-9 format)
+ :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
(format:tabulate modifier params)
(anychar-dispatch))
((#\Y) ; Pretty-print
- (require 'pretty-print)
(pretty-print (next-arg) format:port)
(set! format:output-col 0)
(anychar-dispatch))
;; quoted strings so that the output can always be processed by (read)
(define (format:obj->str obj slashify)
- (cond
- ((string? obj)
- (if slashify
- (let ((obj-len (string-length obj)))
- (string-append
- "\""
- (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
- (if (= j obj-len)
- (string-append (substring obj i j) "\"")
- (let ((c (string-ref obj j)))
- (if (or (char=? c #\\)
- (char=? c #\"))
- (string-append (substring obj i j) "\\"
- (loop j (+ j 1)))
- (loop i (+ j 1))))))))
- obj))
+ (define (obj->str obj slashify visited)
+ (if (memq obj (cdr visited))
+ (let ((n (- (list-index (cdr visited) (cdr obj)))))
+ (string-append "#" (number->string n) "#"))
+ (cond
+ ((string? obj)
+ (if slashify
+ (let ((obj-len (string-length obj)))
+ (string-append
+ "\""
+ (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
+ (if (= j obj-len)
+ (string-append (substring obj i j) "\"")
+ (let ((c (string-ref obj j)))
+ (if (or (char=? c #\\)
+ (char=? c #\"))
+ (string-append (substring obj i j) "\\"
+ (loop j (+ j 1)))
+ (loop i (+ j 1))))))))
+ obj))
- ((boolean? obj) (if obj "#t" "#f"))
+ ((boolean? obj) (if obj "#t" "#f"))
- ((number? obj) (number->string obj))
+ ((number? obj) (number->string obj))
- ((symbol? obj)
- (if format:symbol-case-conv
- (format:symbol-case-conv (symbol->string obj))
- (symbol->string obj)))
+ ((symbol? obj)
+ (if format:symbol-case-conv
+ (format:symbol-case-conv (symbol->string obj))
+ (symbol->string obj)))
- ((char? obj)
- (if slashify
- (format:char->str obj)
- (string obj)))
+ ((char? obj)
+ (if slashify
+ (format:char->str obj)
+ (string obj)))
- ((null? obj) "()")
+ ((null? obj) "()")
- ((input-port? obj)
- (format:iobj->str obj))
+ ((input-port? obj)
+ (format:iobj->str obj))
- ((output-port? obj)
- (format:iobj->str obj))
+ ((output-port? obj)
+ (format:iobj->str obj))
- ((list? obj)
- (string-append "("
- (let loop ((obj-list obj))
- (if (null? (cdr obj-list))
- (format:obj->str (car obj-list) #t)
- (string-append
- (format:obj->str (car obj-list) #t)
- " "
- (loop (cdr obj-list)))))
- ")"))
-
- ((pair? obj)
- (string-append "("
- (format:obj->str (car obj) #t)
- " . "
- (format:obj->str (cdr obj) #t)
- ")"))
-
- ((vector? obj)
- (string-append "#" (format:obj->str (vector->list obj) #t)))
-
- (else ; only objects with an #<...>
- (format:iobj->str obj)))) ; representation should fall in here
+ ((pair? obj)
+ (string-append "("
+ (let loop ((obj-list obj)
+ (visited visited)
+ (offset 0)
+ (prefix ""))
+ (cond ((null? (cdr obj-list))
+ (string-append
+ prefix
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))))
+ ((memq (cdr obj-list) visited)
+ (string-append
+ prefix
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))
+ " . #"
+ (number->string
+ (- offset
+ (list-index visited (cdr obj-list))))
+ "#"))
+ ((pair? (cdr obj-list))
+ (loop (cdr obj-list)
+ (cons (cdr obj-list) visited)
+ (+ 1 offset)
+ (string-append
+ prefix
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))
+ " ")))
+ (else
+ (string-append
+ prefix
+ (obj->str (car obj-list)
+ #t
+ (cons (car obj-list) visited))
+ " . "
+ (obj->str (cdr obj-list)
+ #t
+ (cons (cdr obj-list) visited))))))
+ ")"))
+
+ ((vector? obj)
+ (string-append "#" (obj->str (vector->list obj) #t visited)))
+
+ (else ; only objects with an #<...>
+ (format:iobj->str obj))))) ; representation should fall in here
+ (obj->str obj slashify (list obj)))
;; format:iobj->str reveals the implementation dependent representation of
;; #<...> objects with the use of display and call-with-output-string.
(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
-(variable-set! (builtin-variable 'format) format:format)
+(module-set! the-root-module 'format format)
;; If this is not possible then a continuation is used to recover
;; properly from a format error. In this case format returns #f.
HCoop / bpt / guile.git / blobdiff