1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-13 07:10:20 +02:00

more format tweaks

* module/ice-9/format.scm (format): Strip format: prefix from port and
  output-col.
This commit is contained in:
Andy Wingo 2010-12-18 13:02:07 +01:00
parent 8390dac023
commit 79f124ac87

View file

@ -47,7 +47,7 @@
(if (not (string? format-string)) (if (not (string? format-string))
(error "format: expected a string for format string" format-string)) (error "format: expected a string for format string" format-string))
(let* ((format:port (let* ((port
(cond (cond
((not destination) (open-output-string)) ((not destination) (open-output-string))
((boolean? destination) (current-output-port)) ; boolean but not false ((boolean? destination) (current-output-port)) ; boolean but not false
@ -59,7 +59,7 @@
(current-error-port)) (current-error-port))
(else (else
(error "format: bad destination `~a'" destination)))) (error "format: bad destination `~a'" destination))))
(format:output-col (or (port-column format:port) 0))) (output-col (or (port-column port) 0)))
(define format:version "3.0") (define format:version "3.0")
(define format:flush-output #f) ; flush output at end of formatting (define format:flush-output #f) ; flush output at end of formatting
@ -68,34 +68,34 @@
(define format:arg-pos 0) ; curr. format argument position (define format:arg-pos 0) ; curr. format argument position
; this is global for error presentation ; this is global for error presentation
;; format string and char output routines on format:port ;; format string and char output routines on port
(define (format:out-str str) (define (format:out-str str)
(if format:case-conversion (if format:case-conversion
(display (format:case-conversion str) format:port) (display (format:case-conversion str) port)
(display str format:port)) (display str port))
(set! format:output-col (set! output-col
(+ format:output-col (string-length str)))) (+ output-col (string-length str))))
(define (format:out-char ch) (define (format:out-char ch)
(if format:case-conversion (if format:case-conversion
(display (format:case-conversion (string ch)) (display (format:case-conversion (string ch))
format:port) port)
(write-char ch format:port)) (write-char ch port))
(set! format:output-col (set! output-col
(if (char=? ch #\newline) (if (char=? ch #\newline)
0 0
(+ format:output-col 1)))) (+ output-col 1))))
;;(define (format:out-substr str i n) ; this allocates a new string ;;(define (format:out-substr str i n) ; this allocates a new string
;; (display (substring str i n) format:port) ;; (display (substring str i n) port)
;; (set! format:output-col (+ format:output-col n))) ;; (set! output-col (+ output-col n)))
(define (format:out-substr str i n) (define (format:out-substr str i n)
(do ((k i (+ k 1))) (do ((k i (+ k 1)))
((= k n)) ((= k n))
(write-char (string-ref str k) format:port)) (write-char (string-ref str k) port))
(set! format:output-col (+ format:output-col (- n i)))) (set! output-col (+ output-col (- n i))))
;;(define (format:out-fill n ch) ; this allocates a new string ;;(define (format:out-fill n ch) ; this allocates a new string
;; (format:out-str (make-string n ch))) ;; (format:out-str (make-string n ch)))
@ -103,8 +103,8 @@
(define (format:out-fill n ch) (define (format:out-fill n ch)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i n)) ((= i n))
(write-char ch format:port)) (write-char ch port))
(set! format:output-col (+ format:output-col n))) (set! output-col (+ output-col n)))
;; format's user error handler ;; format's user error handler
@ -371,7 +371,7 @@
(if (one-positive-integer? params) (if (one-positive-integer? params)
(format:out-fill (car params) #\newline) (format:out-fill (car params) #\newline)
(format:out-char #\newline)) (format:out-char #\newline))
(set! format:output-col 0) (set! output-col 0)
(anychar-dispatch)) (anychar-dispatch))
((#\&) ; Fresh line ((#\&) ; Fresh line
(if (one-positive-integer? params) (if (one-positive-integer? params)
@ -379,11 +379,11 @@
(if (> (car params) 0) (if (> (car params) 0)
(format:out-fill (- (car params) (format:out-fill (- (car params)
(if (> (if (>
format:output-col output-col
0) 0 1)) 0) 0 1))
#\newline)) #\newline))
(set! format:output-col 0)) (set! output-col 0))
(if (> format:output-col 0) (if (> output-col 0)
(format:out-char #\newline))) (format:out-char #\newline)))
(anychar-dispatch)) (anychar-dispatch))
((#\_) ; Space character ((#\_) ; Space character
@ -400,7 +400,7 @@
(if (one-positive-integer? params) (if (one-positive-integer? params)
(format:out-fill (car params) #\page) (format:out-fill (car params) #\page)
(format:out-char #\page)) (format:out-char #\page))
(set! format:output-col 0) (set! output-col 0)
(anychar-dispatch)) (anychar-dispatch))
((#\T) ; Tabulate ((#\T) ; Tabulate
(format:tabulate modifier params) (format:tabulate modifier params)
@ -423,14 +423,14 @@
(truncated-print (next-arg) (truncated-print (next-arg)
#:width #:width
(max (- width (max (- width
format:output-col) output-col)
1)))))) 1))))))
((colon) ((colon)
(format:error "illegal modifier in ~~?")) (format:error "illegal modifier in ~~?"))
(else (else
(pretty-print (next-arg) format:port (pretty-print (next-arg) port
#:width width) #:width width)
(set! format:output-col 0)))) (set! output-col 0))))
(anychar-dispatch)) (anychar-dispatch))
((#\? #\K) ; Indirection (is "~K" in T-Scheme) ((#\? #\K) ; Indirection (is "~K" in T-Scheme)
(cond (cond
@ -875,21 +875,21 @@
(if (= colinc 0) (if (= colinc 0)
colnum ; colnum = colrel colnum ; colnum = colrel
(do ((c 0 (+ c colinc)) (do ((c 0 (+ c colinc))
(col (+ format:output-col colnum))) (col (+ output-col colnum)))
((>= c col) ((>= c col)
(- c format:output-col)))) (- c output-col))))
padch)) padch))
(else ; absolute tabulation (else ; absolute tabulation
(format:out-fill (format:out-fill
(cond (cond
((< format:output-col colnum) ((< output-col colnum)
(- colnum format:output-col)) (- colnum output-col))
((= colinc 0) ((= colinc 0)
0) 0)
(else (else
(do ((c colnum (+ c colinc))) (do ((c colnum (+ c colinc)))
((>= c format:output-col) ((>= c output-col)
(- c format:output-col))))) (- c output-col)))))
padch)))))) padch))))))
@ -1600,11 +1600,11 @@
(format:error "~a missing argument~:p" (- arg-pos arg-len))) (format:error "~a missing argument~:p" (- arg-pos arg-len)))
(else (else
(if format:flush-output (if format:flush-output
(force-output format:port)) (force-output port))
(if destination (if destination
#t #t
(let ((str (get-output-string format:port))) (let ((str (get-output-string port)))
(close-port format:port) (close-port port)
str))))))) str)))))))
(begin-deprecated (begin-deprecated