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:
parent
8390dac023
commit
79f124ac87
1 changed files with 34 additions and 34 deletions
|
@ -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
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue