mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-12 06:41:13 +02:00
letrec -> internal definitions in format.scm
* module/ice-9/format.scm (format): Change from letrec to internal definitions, and use the define (foo ...) .. shorthand. No semantic change.
This commit is contained in:
Andy Wingo
parent
9ebf1af3c1
commit
29d096c8e6
1 changed files with 1469 additions and 1506 deletions
|
|
@ -45,29 +45,26 @@
|
|||
;;; End of configuration ----------------------------------------------------
|
||||
|
||||
(define (format . args)
|
||||
(letrec
|
||||
((format:version "3.0")
|
||||
(format:port #f) ; curr. format output port
|
||||
(format:output-col 0) ; curr. format output tty column
|
||||
(format:flush-output #f) ; flush output at end of formatting
|
||||
(format:case-conversion #f)
|
||||
(format:args #f)
|
||||
(format:pos 0) ; curr. format string parsing position
|
||||
(format:arg-pos 0) ; curr. format argument position
|
||||
(define format:version "3.0")
|
||||
(define format:port #f) ; curr. format output port
|
||||
(define format:output-col 0) ; curr. format output tty column
|
||||
(define format:flush-output #f) ; flush output at end of formatting
|
||||
(define format:case-conversion #f)
|
||||
(define format:args #f)
|
||||
(define format:pos 0) ; curr. format string parsing position
|
||||
(define format:arg-pos 0) ; curr. format argument position
|
||||
; this is global for error presentation
|
||||
|
||||
;; format string and char output routines on format:port
|
||||
|
||||
(format:out-str
|
||||
(lambda (str)
|
||||
(define (format:out-str str)
|
||||
(if format:case-conversion
|
||||
(display (format:case-conversion str) format:port)
|
||||
(display str format:port))
|
||||
(set! format:output-col
|
||||
(+ format:output-col (string-length str)))))
|
||||
(+ format:output-col (string-length str))))
|
||||
|
||||
(format:out-char
|
||||
(lambda (ch)
|
||||
(define (format:out-char ch)
|
||||
(if format:case-conversion
|
||||
(display (format:case-conversion (string ch))
|
||||
format:port)
|
||||
|
|
@ -75,33 +72,30 @@
|
|||
(set! format:output-col
|
||||
(if (char=? ch #\newline)
|
||||
0
|
||||
(+ format:output-col 1)))))
|
||||
(+ format:output-col 1))))
|
||||
|
||||
;;(define (format:out-substr str i n) ; this allocates a new string
|
||||
;; (display (substring str i n) format:port)
|
||||
;; (set! format:output-col (+ format:output-col n)))
|
||||
|
||||
(format:out-substr
|
||||
(lambda (str i n)
|
||||
(define (format:out-substr str i n)
|
||||
(do ((k i (+ k 1)))
|
||||
((= k n))
|
||||
(write-char (string-ref str k) format:port))
|
||||
(set! format:output-col (+ format:output-col (- n i)))))
|
||||
(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)))
|
||||
|
||||
(format:out-fill
|
||||
(lambda (n ch)
|
||||
(define (format:out-fill n ch)
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i n))
|
||||
(write-char ch format:port))
|
||||
(set! format:output-col (+ format:output-col n))))
|
||||
(set! format:output-col (+ format:output-col n)))
|
||||
|
||||
;; format's user error handler
|
||||
|
||||
(format:error
|
||||
(lambda args ; never returns!
|
||||
(define (format:error . args) ; never returns!
|
||||
(let ((format-args format:args)
|
||||
(port (current-error-port)))
|
||||
(set! format:error format:intern-error)
|
||||
|
|
@ -125,21 +119,19 @@
|
|||
(apply format port args)
|
||||
(newline port)
|
||||
(set! format:error format:error-save)
|
||||
(format:abort))))
|
||||
(format:abort)))
|
||||
|
||||
(format:intern-error
|
||||
(lambda args
|
||||
(define (format:intern-error . args)
|
||||
;;if something goes wrong in format:error
|
||||
(display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
|
||||
(display " format args: ") (write format:args) (newline)
|
||||
(display " error args: ") (write args) (newline)
|
||||
(set! format:error format:error-save)
|
||||
(format:abort)))
|
||||
(format:abort))
|
||||
|
||||
(format:error-save #f)
|
||||
(define format:error-save #f)
|
||||
|
||||
(format:format
|
||||
(lambda args ; the formatter entry
|
||||
(define (format:format . args) ; the formatter entry
|
||||
(set! format:args args)
|
||||
(set! format:arg-pos 0)
|
||||
(set! format:pos 0)
|
||||
|
|
@ -176,10 +168,9 @@
|
|||
(call-with-output-string
|
||||
(lambda (port) (format:out port (car arglist) (cdr arglist)))))
|
||||
(else
|
||||
(format:error "illegal destination `~a'" destination)))))))
|
||||
(format:error "illegal destination `~a'" destination))))))
|
||||
|
||||
(format:out ; the output handler for a port
|
||||
(lambda (port fmt args)
|
||||
(define (format:out port fmt args) ; the output handler for a port
|
||||
(set! format:port port) ; global port for
|
||||
; output routines
|
||||
(set! format:case-conversion #f) ; modifier case
|
||||
|
|
@ -196,13 +187,12 @@
|
|||
(format:error "~a missing argument~:p" (- arg-pos arg-len)))
|
||||
(else
|
||||
(if format:flush-output (force-output port))
|
||||
#t)))))
|
||||
#t))))
|
||||
|
||||
(format:parameter-characters
|
||||
(define format:parameter-characters
|
||||
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
|
||||
|
||||
(format:format-work ; does the formatting work
|
||||
(lambda (format-string arglist)
|
||||
(define (format:format-work format-string arglist) ; does the formatting work
|
||||
(letrec
|
||||
((format-string-len (string-length format-string))
|
||||
(arg-pos 0) ; argument position in arglist
|
||||
|
|
@ -810,33 +800,31 @@
|
|||
(set! format:arg-pos 0)
|
||||
(anychar-dispatch) ; start the formatting
|
||||
(set! format:pos recursive-pos-save)
|
||||
arg-pos))) ; return the position in the arg. list
|
||||
arg-pos)) ; return the position in the arg. list
|
||||
|
||||
;; when format:read-proof is true, format:obj->str will wrap
|
||||
;; result strings starting with "#<" in an extra pair of double
|
||||
;; quotes.
|
||||
|
||||
(format:read-proof #f)
|
||||
(define format:read-proof #f)
|
||||
|
||||
;; format:obj->str returns a R4RS representation as a string of
|
||||
;; an arbitrary scheme object.
|
||||
|
||||
(format:obj->str
|
||||
(lambda (obj slashify)
|
||||
(define (format:obj->str obj slashify)
|
||||
(let ((res (if slashify
|
||||
(object->string obj)
|
||||
(with-output-to-string (lambda () (display obj))))))
|
||||
(if (and format:read-proof (string-prefix? "#<" res))
|
||||
(object->string res)
|
||||
res))))
|
||||
res)))
|
||||
|
||||
;; format:char->str converts a character into a slashified string as
|
||||
;; done by `write'. The procedure is dependent on the integer
|
||||
;; representation of characters and assumes a character number according to
|
||||
;; the ASCII character set.
|
||||
|
||||
(format:char->str
|
||||
(lambda (ch)
|
||||
(define (format:char->str ch)
|
||||
(let ((int-rep (char->integer ch)))
|
||||
(if (< int-rep 0) ; if chars are [-128...+127]
|
||||
(set! int-rep (+ int-rep 256)))
|
||||
|
|
@ -849,13 +837,12 @@
|
|||
((= int-rep 127) "del")
|
||||
((>= int-rep 128) ; octal representation
|
||||
(number->string int-rep 8))
|
||||
(else (string ch)))))))
|
||||
(else (string ch))))))
|
||||
|
||||
(format:space-ch (char->integer #\space))
|
||||
(format:zero-ch (char->integer #\0))
|
||||
(define format:space-ch (char->integer #\space))
|
||||
(define format:zero-ch (char->integer #\0))
|
||||
|
||||
(format:par
|
||||
(lambda (pars length index default name)
|
||||
(define (format:par pars length index default name)
|
||||
(if (> length index)
|
||||
(let ((par (list-ref pars index)))
|
||||
(if par
|
||||
|
|
@ -866,10 +853,9 @@
|
|||
par)
|
||||
par)
|
||||
default))
|
||||
default)))
|
||||
default))
|
||||
|
||||
(format:out-obj-padded
|
||||
(lambda (pad-left obj slashify pars)
|
||||
(define (format:out-obj-padded pad-left obj slashify pars)
|
||||
(if (null? pars)
|
||||
(format:out-str (format:obj->str obj slashify))
|
||||
(let ((l (length pars)))
|
||||
|
|
@ -886,10 +872,9 @@
|
|||
((>= (+ objstr-len i) mincol)
|
||||
(format:out-fill i padchar)))
|
||||
(if pad-left
|
||||
(format:out-str objstr)))))))
|
||||
(format:out-str objstr))))))
|
||||
|
||||
(format:out-num-padded
|
||||
(lambda (modifier number pars radix)
|
||||
(define (format:out-num-padded modifier number pars radix)
|
||||
(if (not (integer? number)) (format:error "argument not an integer"))
|
||||
(let ((numstr (number->string number radix)))
|
||||
(if (and (null? pars) (not modifier))
|
||||
|
|
@ -925,10 +910,9 @@
|
|||
(if (> i ns)
|
||||
(format:out-char commachar))
|
||||
(format:out-substr numstr i (+ i commawidth))))
|
||||
(format:out-str numstr))))))))
|
||||
(format:out-str numstr)))))))
|
||||
|
||||
(format:tabulate
|
||||
(lambda (modifier pars)
|
||||
(define (format:tabulate modifier pars)
|
||||
(let ((l (length pars)))
|
||||
(let ((colnum (format:par pars l 0 1 "colnum"))
|
||||
(colinc (format:par pars l 1 1 "colinc"))
|
||||
|
|
@ -956,20 +940,19 @@
|
|||
(do ((c colnum (+ c colinc)))
|
||||
((>= c format:output-col)
|
||||
(- c format:output-col)))))
|
||||
padch)))))))
|
||||
padch))))))
|
||||
|
||||
|
||||
;; roman numerals (from dorai@cs.rice.edu).
|
||||
|
||||
(format:roman-alist
|
||||
(define format:roman-alist
|
||||
'((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
|
||||
(10 #\X) (5 #\V) (1 #\I)))
|
||||
|
||||
(format:roman-boundary-values
|
||||
(define format:roman-boundary-values
|
||||
'(100 100 10 10 1 1 #f))
|
||||
|
||||
(format:num->old-roman
|
||||
(lambda (n)
|
||||
(define (format:num->old-roman n)
|
||||
(if (and (integer? n) (>= n 1))
|
||||
(let loop ((n n)
|
||||
(romans format:roman-alist)
|
||||
|
|
@ -982,10 +965,9 @@
|
|||
((= q 0)
|
||||
(loop (remainder n roman-val)
|
||||
(cdr romans) s))))))
|
||||
(format:error "only positive integers can be romanized"))))
|
||||
(format:error "only positive integers can be romanized")))
|
||||
|
||||
(format:num->roman
|
||||
(lambda (n)
|
||||
(define (format:num->roman n)
|
||||
(if (and (integer? n) (> n 0))
|
||||
(let loop ((n n)
|
||||
(romans format:roman-alist)
|
||||
|
|
@ -1009,26 +991,25 @@
|
|||
s)))
|
||||
(loop r (cdr romans) (cdr boundaries) s))
|
||||
(loop2 (- q 1) r (cons roman-dgt s)))))))
|
||||
(format:error "only positive integers can be romanized"))))
|
||||
(format:error "only positive integers can be romanized")))
|
||||
|
||||
;; cardinals & ordinals (from dorai@cs.rice.edu)
|
||||
|
||||
(format:cardinal-ones-list
|
||||
(define format:cardinal-ones-list
|
||||
'(#f "one" "two" "three" "four" "five"
|
||||
"six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
|
||||
"fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
|
||||
"nineteen"))
|
||||
|
||||
(format:cardinal-tens-list
|
||||
(define format:cardinal-tens-list
|
||||
'(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
|
||||
"ninety"))
|
||||
|
||||
(format:num->cardinal999
|
||||
(lambda (n)
|
||||
;this procedure is inspired by the Bruno Haible's CLisp
|
||||
;function format-small-cardinal, which converts numbers
|
||||
;in the range 1 to 999, and is used for converting each
|
||||
;thousand-block in a larger number
|
||||
(define (format:num->cardinal999 n)
|
||||
;; this procedure is inspired by the Bruno Haible's CLisp
|
||||
;; function format-small-cardinal, which converts numbers
|
||||
;; in the range 1 to 999, and is used for converting each
|
||||
;; thousand-block in a larger number
|
||||
(let* ((hundreds (quotient n 100))
|
||||
(tens+ones (remainder n 100))
|
||||
(tens (quotient tens+ones 10))
|
||||
|
|
@ -1053,17 +1034,16 @@
|
|||
(cons #\-
|
||||
(string->list
|
||||
(list-ref format:cardinal-ones-list ones)))
|
||||
'())))))))
|
||||
'()))))))
|
||||
|
||||
(format:cardinal-thousand-block-list
|
||||
(define format:cardinal-thousand-block-list
|
||||
'("" " thousand" " million" " billion" " trillion" " quadrillion"
|
||||
" quintillion" " sextillion" " septillion" " octillion" " nonillion"
|
||||
" decillion" " undecillion" " duodecillion" " tredecillion"
|
||||
" quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
|
||||
" octodecillion" " novemdecillion" " vigintillion"))
|
||||
|
||||
(format:num->cardinal
|
||||
(lambda (n)
|
||||
(define (format:num->cardinal n)
|
||||
(cond ((not (integer? n))
|
||||
(format:error
|
||||
"only integers can be converted to English cardinals"))
|
||||
|
|
@ -1098,20 +1078,19 @@
|
|||
(* power3 3)))
|
||||
(string->list " power")))
|
||||
s)
|
||||
s))))))))))
|
||||
s)))))))))
|
||||
|
||||
(format:ordinal-ones-list
|
||||
(define format:ordinal-ones-list
|
||||
'(#f "first" "second" "third" "fourth" "fifth"
|
||||
"sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
|
||||
"thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
|
||||
"eighteenth" "nineteenth"))
|
||||
|
||||
(format:ordinal-tens-list
|
||||
(define format:ordinal-tens-list
|
||||
'(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
|
||||
"seventieth" "eightieth" "ninetieth"))
|
||||
|
||||
(format:num->ordinal
|
||||
(lambda (n)
|
||||
(define (format:num->ordinal n)
|
||||
(cond ((not (integer? n))
|
||||
(format:error
|
||||
"only integers can be converted to English ordinals"))
|
||||
|
|
@ -1137,16 +1116,14 @@
|
|||
(list-ref format:cardinal-tens-list tens)
|
||||
"-"
|
||||
(list-ref format:ordinal-ones-list ones))))
|
||||
))))))))
|
||||
)))))))
|
||||
|
||||
;; format inf and nan.
|
||||
|
||||
(format:out-inf-nan
|
||||
(lambda (number width digits edigits overch padch)
|
||||
(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 #\.))
|
||||
|
|
@ -1163,12 +1140,11 @@
|
|||
(padch (integer->char (or padch format:space-ch))))
|
||||
(format:out-fill leftpad padch)
|
||||
(format:out-str str)
|
||||
(format:out-fill rightpad padch))))))
|
||||
(format:out-fill rightpad padch)))))
|
||||
|
||||
;; format fixed flonums (~F)
|
||||
|
||||
(format:out-fixed
|
||||
(lambda (modifier number pars)
|
||||
(define (format:out-fixed modifier number pars)
|
||||
(if (not (or (number? number) (string? number)))
|
||||
(format:error "argument is not a number or a number string"))
|
||||
|
||||
|
|
@ -1223,12 +1199,11 @@
|
|||
(format:fn-round (- width dot-index))
|
||||
(format:fn-out modifier #t))))
|
||||
(format:fn-out modifier #t)))
|
||||
(format:fn-out modifier #t))))))))
|
||||
(format:fn-out modifier #t)))))))
|
||||
|
||||
;; format exponential flonums (~E)
|
||||
|
||||
(format:out-expon
|
||||
(lambda (modifier number pars)
|
||||
(define (format:out-expon modifier number pars)
|
||||
(if (not (or (number? number) (string? number)))
|
||||
(format:error "argument is not a number"))
|
||||
|
||||
|
|
@ -1318,12 +1293,11 @@
|
|||
(format:en-out edigits expch)))))
|
||||
(begin
|
||||
(format:fn-out modifier #t)
|
||||
(format:en-out edigits expch)))))))))
|
||||
(format:en-out edigits expch))))))))
|
||||
|
||||
;; format general flonums (~G)
|
||||
|
||||
(format:out-general
|
||||
(lambda (modifier number pars)
|
||||
(define (format:out-general modifier number pars)
|
||||
(if (not (or (number? number) (string? number)))
|
||||
(format:error "argument is not a number or a number string"))
|
||||
|
||||
|
|
@ -1353,12 +1327,11 @@
|
|||
(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:out-expon modifier number pars))))))))
|
||||
|
||||
;; format dollar flonums (~$)
|
||||
|
||||
(format:out-dollar
|
||||
(lambda (modifier number pars)
|
||||
(define (format:out-dollar modifier number pars)
|
||||
(if (not (or (number? number) (string? number)))
|
||||
(format:error "argument is not a number or a number string"))
|
||||
|
||||
|
|
@ -1409,22 +1382,21 @@
|
|||
(format:out-char #\0))
|
||||
(format:out-substr format:fn-str 0 format:fn-dot)
|
||||
(format:out-char #\.)
|
||||
(format:out-substr format:fn-str format:fn-dot format:fn-len)))))))
|
||||
(format:out-substr format:fn-str format:fn-dot format:fn-len))))))
|
||||
|
||||
; the flonum buffers
|
||||
|
||||
(format:fn-max 400) ; max. number of number digits
|
||||
(format:fn-str #f) ; number buffer
|
||||
(format:fn-len 0) ; digit length of number
|
||||
(format:fn-dot #f) ; dot position of number
|
||||
(format:fn-pos? #t) ; number positive?
|
||||
(format:en-max 10) ; max. number of exponent digits
|
||||
(format:en-str #f) ; exponent buffer
|
||||
(format:en-len 0) ; digit length of exponent
|
||||
(format:en-pos? #t) ; exponent positive?
|
||||
(define format:fn-max 400) ; max. number of number digits
|
||||
(define format:fn-str #f) ; number buffer
|
||||
(define format:fn-len 0) ; digit length of number
|
||||
(define format:fn-dot #f) ; dot position of number
|
||||
(define format:fn-pos? #t) ; number positive?
|
||||
(define format:en-max 10) ; max. number of exponent digits
|
||||
(define format:en-str #f) ; exponent buffer
|
||||
(define format:en-len 0) ; digit length of exponent
|
||||
(define format:en-pos? #t) ; exponent positive?
|
||||
|
||||
(format:parse-float
|
||||
(lambda (num fixed? scale)
|
||||
(define (format:parse-float num fixed? scale)
|
||||
(let ((num-str (if (string? num)
|
||||
num
|
||||
(number->string (exact->inexact num)))))
|
||||
|
|
@ -1540,10 +1512,9 @@
|
|||
((char=? c #\d) #t) ; decimal radix prefix
|
||||
((char=? c #\#) #t)
|
||||
(else
|
||||
(format:error "illegal character `~c' in number->string" c)))))))
|
||||
(format:error "illegal character `~c' in number->string" c))))))
|
||||
|
||||
(format:en-int
|
||||
(lambda () ; convert exponent string to integer
|
||||
(define (format:en-int) ; convert exponent string to integer
|
||||
(if (= format:en-len 0)
|
||||
0
|
||||
(do ((i 0 (+ i 1))
|
||||
|
|
@ -1553,10 +1524,9 @@
|
|||
n
|
||||
(- n)))
|
||||
(set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
|
||||
format:zero-ch)))))))
|
||||
format:zero-ch))))))
|
||||
|
||||
(format:en-set ; set exponent string number
|
||||
(lambda (en)
|
||||
(define (format:en-set en) ; set exponent string number
|
||||
(set! format:en-len 0)
|
||||
(set! format:en-pos? (>= en 0))
|
||||
(let ((en-str (number->string en)))
|
||||
|
|
@ -1568,10 +1538,9 @@
|
|||
(if (char-numeric? c)
|
||||
(begin
|
||||
(string-set! format:en-str format:en-len c)
|
||||
(set! format:en-len (+ format:en-len 1))))))))
|
||||
(set! format:en-len (+ format:en-len 1)))))))
|
||||
|
||||
(format:fn-zfill ; fill current number string with 0s
|
||||
(lambda (left? n)
|
||||
(define (format:fn-zfill left? n) ; fill current number string with 0s
|
||||
(if (> (+ n format:fn-len) format:fn-max) ; from the left or right
|
||||
(format:error "number is too long to format (enlarge format:fn-max)"))
|
||||
(set! format:fn-len (+ format:fn-len n))
|
||||
|
|
@ -1584,20 +1553,18 @@
|
|||
(string-ref format:fn-str (- i n)))))
|
||||
(do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
|
||||
((= i format:fn-len))
|
||||
(string-set! format:fn-str i #\0)))))
|
||||
(string-set! format:fn-str i #\0))))
|
||||
|
||||
(format:fn-shiftleft ; shift left current number n positions
|
||||
(lambda (n)
|
||||
(define (format:fn-shiftleft n) ; shift left current number n positions
|
||||
(if (> n format:fn-len)
|
||||
(format:error "internal error in format:fn-shiftleft (~d,~d)"
|
||||
n format:fn-len))
|
||||
(do ((i n (+ i 1)))
|
||||
((= i format:fn-len)
|
||||
(set! format:fn-len (- format:fn-len n)))
|
||||
(string-set! format:fn-str (- i n) (string-ref format:fn-str i)))))
|
||||
(string-set! format:fn-str (- i n) (string-ref format:fn-str i))))
|
||||
|
||||
(format:fn-round ; round format:fn-str
|
||||
(lambda (digits)
|
||||
(define (format:fn-round digits) ; round format:fn-str
|
||||
(set! digits (+ digits format:fn-dot))
|
||||
(do ((i digits (- i 1)) ; "099",2 -> "10"
|
||||
(c 5)) ; "023",2 -> "02"
|
||||
|
|
@ -1615,10 +1582,9 @@
|
|||
(if (< c 10)
|
||||
(+ c format:zero-ch)
|
||||
(+ (- c 10) format:zero-ch))))
|
||||
(set! c (if (< c 10) 0 1)))))
|
||||
(set! c (if (< c 10) 0 1))))
|
||||
|
||||
(format:fn-out
|
||||
(lambda (modifier add-leading-zero?)
|
||||
(define (format:fn-out modifier add-leading-zero?)
|
||||
(if format:fn-pos?
|
||||
(if (eq? modifier 'at)
|
||||
(format:out-char #\+))
|
||||
|
|
@ -1628,39 +1594,35 @@
|
|||
(format:out-char #\0))
|
||||
(format:out-substr format:fn-str 0 format:fn-dot))
|
||||
(format:out-char #\.)
|
||||
(format:out-substr format:fn-str format:fn-dot format:fn-len)))
|
||||
(format:out-substr format:fn-str format:fn-dot format:fn-len))
|
||||
|
||||
(format:en-out
|
||||
(lambda (edigits expch)
|
||||
(define (format:en-out edigits expch)
|
||||
(format:out-char (if expch (integer->char expch) #\E))
|
||||
(format:out-char (if format:en-pos? #\+ #\-))
|
||||
(if edigits
|
||||
(if (< format:en-len edigits)
|
||||
(format:out-fill (- edigits format:en-len) #\0)))
|
||||
(format:out-substr format:en-str 0 format:en-len)))
|
||||
(format:out-substr format:en-str 0 format:en-len))
|
||||
|
||||
(format:fn-strip ; strip trailing zeros but one
|
||||
(lambda ()
|
||||
(define (format:fn-strip) ; strip trailing zeros but one
|
||||
(string-set! format:fn-str format:fn-len #\0)
|
||||
(do ((i format:fn-len (- i 1)))
|
||||
((or (not (char=? (string-ref format:fn-str i) #\0))
|
||||
(<= i format:fn-dot))
|
||||
(set! format:fn-len (+ i 1))))))
|
||||
(set! format:fn-len (+ i 1)))))
|
||||
|
||||
(format:fn-zlead ; count leading zeros
|
||||
(lambda ()
|
||||
(define (format:fn-zlead) ; count leading zeros
|
||||
(do ((i 0 (+ i 1)))
|
||||
((or (= i format:fn-len)
|
||||
(not (char=? (string-ref format:fn-str i) #\0)))
|
||||
(if (= i format:fn-len) ; found a real zero
|
||||
0
|
||||
i)))))
|
||||
i))))
|
||||
|
||||
|
||||
;;; some global functions not found in SLIB
|
||||
|
||||
(string-capitalize-first ; "hello" -> "Hello"
|
||||
(lambda (str)
|
||||
(define (string-capitalize-first str) ; "hello" -> "Hello"
|
||||
(let ((cap-str (string-copy str)) ; "hELLO" -> "Hello"
|
||||
(non-first-alpha #f) ; "*hello" -> "*Hello"
|
||||
(str-len (string-length str))) ; "hello you" -> "Hello you"
|
||||
|
|
@ -1672,17 +1634,18 @@
|
|||
(string-set! cap-str i (char-downcase c))
|
||||
(begin
|
||||
(set! non-first-alpha #t)
|
||||
(string-set! cap-str i (char-upcase c))))))))))
|
||||
(string-set! cap-str i (char-upcase c)))))))))
|
||||
|
||||
;; Aborts the program when a formatting error occures. This is a null
|
||||
;; argument closure to jump to the interpreters toplevel continuation.
|
||||
|
||||
(format:abort (lambda () (error "error in format"))))
|
||||
(define (format:abort) (error "error in format"))
|
||||
|
||||
(set! format:error-save format:error)
|
||||
(set! format:fn-str (make-string format:fn-max)) ; number buffer
|
||||
(set! format:en-str (make-string format:en-max)) ; exponent buffer
|
||||
(apply format:format args)))
|
||||
|
||||
(apply format:format args))
|
||||
|
||||
;; Thanks to Shuji Narazaki
|
||||
(module-set! the-root-module 'format format)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue