summaryrefslogtreecommitdiffstats
path: root/format.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commitbd9733926076885e3417b74de76e4c9c7bc56254 (patch)
tree2c99dced547d48407ad44cb0e45e31bb4d02ce43 /format.scm
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-bd9733926076885e3417b74de76e4c9c7bc56254.tar.gz
slib-bd9733926076885e3417b74de76e4c9c7bc56254.zip
Import Upstream version 2c7upstream/2c7
Diffstat (limited to 'format.scm')
-rw-r--r--format.scm149
1 files changed, 73 insertions, 76 deletions
diff --git a/format.scm b/format.scm
index e64efa7..d9f1c86 100644
--- a/format.scm
+++ b/format.scm
@@ -113,9 +113,9 @@
(substring format-string 0 format:pos)
(substring format-string format:pos
(string-length format-string))
- (list-head (cddr format:args) format:arg-pos)
+ (format:list-head (cddr format:args) format:arg-pos)
(list-tail (cddr format:args) format:arg-pos)))
- (format port
+ (format port
"~%FORMAT: error with call: (format~{ ~a~})~% "
format:args))
(apply format port args)
@@ -140,28 +140,34 @@
(set! format:pos 0)
(if (< (length args) 1)
(format:error "not enough arguments"))
- (let ((destination (car args))
- (arglist (cdr args)))
- (cond
- ((or (and (boolean? destination) ; port output
- destination)
- (output-port? destination)
- (number? destination))
- (format:out (cond
- ((boolean? destination) (current-output-port))
- ((output-port? destination) destination)
- ((number? destination) (current-error-port)))
- (car arglist) (cdr arglist)))
- ((and (boolean? destination) ; string output
- (not destination))
- (call-with-output-string
- (lambda (port) (format:out port (car arglist) (cdr arglist)))))
- ((string? destination) ; dest. is format string (Scheme->C)
- (call-with-output-string
- (lambda (port)
- (format:out port destination arglist))))
- (else
- (format:error "illegal destination `~a'" destination)))))
+
+ ;; If the first argument is a string, then that's the format string.
+ ;; (Scheme->C)
+ ;; In this case, put the argument list in canonical form.
+ (let ((args (if (string? (car args))
+ (cons #f args)
+ args)))
+ ;; Use this canonicalized version when reporting errors.
+ (set! format:args args)
+
+ (let ((destination (car args))
+ (arglist (cdr args)))
+ (cond
+ ((or (and (boolean? destination) ; port output
+ destination)
+ (output-port? destination)
+ (number? destination))
+ (format:out (cond
+ ((boolean? destination) (current-output-port))
+ ((output-port? destination) destination)
+ ((number? destination) (current-error-port)))
+ (car arglist) (cdr arglist)))
+ ((and (boolean? destination) ; string output
+ (not destination))
+ (call-with-output-string
+ (lambda (port) (format:out port (car arglist) (cdr arglist)))))
+ (else
+ (format:error "illegal destination `~a'" destination))))))
(define (format:out port fmt args) ; the output handler for a port
(set! format:port port) ; global port for output routines
@@ -248,7 +254,7 @@
(if (= k 0) l (loop (cdr l) (- k 1))))))
(add-arg-pos
- (lambda (n)
+ (lambda (n)
(set! arg-pos (+ n arg-pos))
(set! format:arg-pos arg-pos)))
@@ -491,7 +497,7 @@
((#\() ; Case conversion begin
(set! format:case-conversion
(case modifier
- ((at) string-capitalize-first)
+ ((at) format:string-capitalize-first)
((colon) string-capitalize)
((colon-at) string-upcase)
(else string-downcase)))
@@ -529,7 +535,7 @@
(cond
((eq? modifier 'colon)
(set! clause-default #t)
- (substring format-string clause-pos
+ (substring format-string clause-pos
(- format:pos 3)))
((memq modifier '(at colon-at))
(format:error "illegal modifier in ~~;"))
@@ -689,13 +695,14 @@
;; format directive modifiers and parameters
((#\@) ; `@' modifier
- (if (eq? modifier 'colon-at)
+ (if (memq modifier '(at colon-at))
(format:error "double `@' modifier"))
(set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
(tilde-dispatch))
((#\:) ; `:' modifier
- (if modifier (format:error "illegal `:' modifier position"))
- (set! modifier 'colon)
+ (if (memq modifier '(colon colon-at))
+ (format:error "double `:' modifier"))
+ (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
(tilde-dispatch))
((#\') ; Character parameter
(if modifier (format:error "misplaced modifier"))
@@ -782,29 +789,29 @@
(loop j (+ j 1)))
(loop i (+ j 1))))))))
obj))
-
+
((boolean? obj) (if obj "#t" "#f"))
-
+
((number? obj) (number->string obj))
- ((symbol? 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)))
-
+
((null? obj) "()")
((input-port? obj)
(format:iobj->str obj))
-
+
((output-port? obj)
(format:iobj->str obj))
-
+
((list? obj)
(string-append "("
(let loop ((obj-list obj))
@@ -822,16 +829,16 @@
" . "
(format:obj->str (cdr obj) #t)
")"))
-
+
((vector? obj)
(string-append "#" (format:obj->str (vector->list obj) #t)))
- (else ; only objects with an #<...>
+ (else ; only objects with an #<...>
(format:iobj->str obj)))) ; representation should fall in here
-;; format:iobj->str reveals the implementation dependent representation of
+;; format:iobj->str reveals the implementation dependent representation of
;; #<...> objects with the use of display and call-with-output-string.
-;; If format:read-proof is set to #t the resulting string is additionally
+;; If format:read-proof is set to #t the resulting string is additionally
;; set into string quotes.
(define format:read-proof #f)
@@ -839,7 +846,7 @@
(define (format:iobj->str iobj)
(if (or format:read-proof
format:iobj-case-conv)
- (string-append
+ (string-append
(if format:read-proof "\"" "")
(if format:iobj-case-conv
(format:iobj-case-conv
@@ -881,7 +888,7 @@
(if par
(if name
(if (< par 0)
- (format:error
+ (format:error
"~s parameter must be a positive integer" name)
par)
par)
@@ -927,7 +934,7 @@
(if (and (memq modifier '(at colon-at)) (> number 0))
(set! numlen (+ numlen 1)))
(if (memq modifier '(colon colon-at))
- (set! numlen (+ (quotient (- numstr-len
+ (set! numlen (+ (quotient (- numstr-len
(if (< number 0) 2 1))
commawidth)
numlen)))
@@ -1071,7 +1078,8 @@
(if (> ones 0)
(cons #\-
(string->list
- (list-ref format:cardinal-ones-list ones))))))))))
+ (list-ref format:cardinal-ones-list ones)))
+ '())))))))
(define format:cardinal-thousand-block-list
'("" " thousand" " million" " billion" " trillion" " quadrillion"
@@ -1173,7 +1181,7 @@
(if digits
(begin ; fixed precision
- (format:parse-float
+ (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)))
@@ -1230,7 +1238,7 @@
(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
(let ((digits (if (> scale 0)
@@ -1238,7 +1246,7 @@
(+ (- digits scale) 1)
0)
digits)))
- (format:parse-float
+ (format:parse-float
(if (string? number) number (number->string number)) #f scale)
(if (<= (- format:fn-len format:fn-dot) digits)
(format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
@@ -1250,11 +1258,11 @@
(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)))
+ (set! numlen (+ numlen 1)))
(set! numlen
- (+ numlen
+ (+ numlen
(if (and edigits (>= edigits format:en-len))
- edigits
+ edigits
format:en-len)))
(if (< numlen width)
(format:out-fill (- width numlen)
@@ -1283,7 +1291,7 @@
(set! numlen
(+ numlen
(if (and edigits (>= edigits format:en-len))
- edigits
+ edigits
format:en-len)))
(if (< numlen width)
(format:out-fill (- width numlen)
@@ -1292,7 +1300,7 @@
(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
+ (format:out-fill width
(integer->char overch))
(begin
(format:fn-out modifier #t)
@@ -1307,7 +1315,7 @@
(begin
(format:fn-out modifier #t)
(format:en-out edigits expch))))))))
-
+
;; format general flonums (~G)
(define (format:out-general modifier number pars)
@@ -1429,7 +1437,7 @@
(begin ; fixed format m.nnn or .nnn
(if (and (> left-zeros 0) (> format:fn-dot 0))
- (if (> format:fn-dot left-zeros)
+ (if (> format:fn-dot left-zeros)
(begin ; norm 0{0}nn.mm to nn.mm
(format:fn-shiftleft left-zeros)
(set! left-zeros 0)
@@ -1470,7 +1478,7 @@
(set! format:fn-dot 1)))
(format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
negexp))
- (cond
+ (cond
(all-zeros?
(format:en-set 0)
(set! format:fn-dot 1))
@@ -1484,10 +1492,10 @@
(set! format:fn-dot scale)))))
#t)
- ;; do body
+ ;; do body
(set! c (string-ref num-str i)) ; parse the output of number->string
(cond ; which can be any valid number
- ((char-numeric? c) ; representation of R4RS except
+ ((char-numeric? c) ; representation of R4RS except
(if mantissa? ; complex numbers
(begin
(if (char=? c #\0)
@@ -1521,7 +1529,7 @@
0
(do ((i 0 (+ i 1))
(n 0))
- ((= i format:en-len)
+ ((= i format:en-len)
(if format:en-pos?
n
(- n)))
@@ -1581,14 +1589,14 @@
(set! c (+ (- (char->integer (string-ref format:fn-str i))
format:zero-ch) c))
(string-set! format:fn-str i (integer->char
- (if (< c 10)
+ (if (< c 10)
(+ c format:zero-ch)
(+ (- c 10) format:zero-ch))))
(set! c (if (< c 10) 0 1))))
(define (format:fn-out modifier add-leading-zero?)
(if format:fn-pos?
- (if (eq? modifier 'at)
+ (if (eq? modifier 'at)
(format:out-char #\+))
(format:out-char #\-))
(if (= format:fn-dot 0)
@@ -1601,7 +1609,7 @@
(define (format:en-out edigits expch)
(format:out-char (if expch (integer->char expch) format:expch))
(format:out-char (if format:en-pos? #\+ #\-))
- (if edigits
+ (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))
@@ -1624,18 +1632,7 @@
;;; 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"
+(define (format: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"
@@ -1649,10 +1646,10 @@
(set! non-first-alpha #t)
(string-set! cap-str i (char-upcase c)))))))))
-(define (list-head l k)
+(define (format:list-head l k)
(if (= k 0)
'()
- (cons (car l) (list-head (cdr l) (- k 1)))))
+ (cons (car l) (format:list-head (cdr l) (- k 1)))))
;; Aborts the program when a formatting error occures. This is a null