diff options
Diffstat (limited to 'format.scm')
| -rw-r--r-- | format.scm | 149 |
1 files changed, 73 insertions, 76 deletions
@@ -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 |