mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-04 16:50:25 +02:00
Code Activity

Refactor `format' to use when/unless conventionally

Browse source 
* module/ice-9/format.scm (format): Update to make one-armed ifs use
  when/unless.
This commit is contained in:
Andy Wingo 2019-08-13 22:22:42 +02:00
parent e2f8ccc5ba
commit 077ba996e8
1 changed files with 279 additions and 272 deletions
Download patch file Download diff file Expand all files Collapse all files

241
module/ice-9/format.scm
View file

@ -1,5 +1,5 @@
;;;; "format.scm" Common LISP text output formatter for SLIB ;;;; "format.scm" Common LISP text output formatter for SLIB
;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;; Copyright (C) 2010-2013,2019 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -37,7 +37,7 @@
(define format:version "3.0") (define format:version "3.0")
(define (format destination format-string . format-args) (define (format destination format-string . format-args)
(if (not (string? format-string)) (unless (string? format-string)
(error "format: expected a string for format string" format-string)) (error "format: expected a string for format string" format-string))
(let* ((port (let* ((port
@ -100,7 +100,7 @@
(define (format:error . args) ; never returns! (define (format:error . args) ; never returns!
(let ((port (current-error-port))) (let ((port (current-error-port)))
(set! format:error format:intern-error) (set! format:error format:intern-error)
(if (not (zero? format:arg-pos)) (unless (zero? format:arg-pos)
(set! format:arg-pos (- format:arg-pos 1))) (set! format:arg-pos (- format:arg-pos 1)))
(format port (format port
"~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
@ -169,9 +169,9 @@
(peek-next-char (peek-next-char
(lambda () (lambda ()
(if (>= format:pos format-string-len) (when (>= format:pos format-string-len)
(format:error "illegal format string") (format:error "illegal format string"))
(string-ref format-string format:pos)))) (string-ref format-string format:pos)))
(one-positive-integer? (one-positive-integer?
(lambda (params) (lambda (params)
@ -186,17 +186,16 @@
(next-arg (next-arg
(lambda () (lambda ()
(if (>= arg-pos arg-len) (when (>= arg-pos arg-len)
(begin
(set! format:arg-pos (+ arg-len 1)) (set! format:arg-pos (+ arg-len 1))
(format:error "missing argument(s)"))) (format:error "missing argument(s)"))
(add-arg-pos 1) (add-arg-pos 1)
(list-ref arglist (- arg-pos 1)))) (list-ref arglist (- arg-pos 1))))
(prev-arg (prev-arg
(lambda () (lambda ()
(add-arg-pos -1) (add-arg-pos -1)
(if (negative? arg-pos) (when (negative? arg-pos)
(format:error "missing backward argument(s)")) (format:error "missing backward argument(s)"))
(list-ref arglist arg-pos))) (list-ref arglist arg-pos)))
@ -222,7 +221,7 @@
(set! param-value-found #f) (set! param-value-found #f)
(tilde-dispatch)) (tilde-dispatch))
(else (else
(if (and (zero? conditional-nest) (when (and (zero? conditional-nest)
(zero? iteration-nest)) (zero? iteration-nest))
(format:out-char char)) (format:out-char char))
(anychar-dispatch))))))) (anychar-dispatch)))))))
@ -321,7 +320,7 @@
(anychar-dispatch)) (anychar-dispatch))
((#\I) ; Complex numbers ((#\I) ; Complex numbers
(let ((z (next-arg))) (let ((z (next-arg)))
(if (not (complex? z)) (unless (complex? z)
(format:error "argument not a complex number")) (format:error "argument not a complex number"))
(format:out-fixed modifier (real-part z) params) (format:out-fixed modifier (real-part z) params)
(format:out-fixed 'at (imag-part z) params) (format:out-fixed 'at (imag-part z) params)
@ -331,14 +330,14 @@
(let ((ch (if (one-positive-integer? params) (let ((ch (if (one-positive-integer? params)
(integer->char (car params)) (integer->char (car params))
(next-arg)))) (next-arg))))
(if (not (char? ch)) (unless (char? ch)
(format:error "~~c expects a character")) (format:error "~~c expects a character"))
(case modifier (case modifier
((at) ((at)
(format:out-str (object->string ch))) (format:out-str (object->string ch)))
((colon) ((colon)
(let ((c (char->integer ch))) (let ((c (char->integer ch)))
(if (< c 0) (when (< c 0)
(set! c (+ c 256))) ; compensate (set! c (+ c 256))) ; compensate
; complement ; complement
; impl. ; impl.
@ -357,13 +356,13 @@
(else (format:out-char ch)))) (else (format:out-char ch))))
(anychar-dispatch)) (anychar-dispatch))
((#\P) ; Plural ((#\P) ; Plural
(if (memq modifier '(colon colon-at)) (when (memq modifier '(colon colon-at))
(prev-arg)) (prev-arg))
(let ((arg (next-arg))) (let ((arg (next-arg)))
(if (not (number? arg)) (unless (number? arg)
(format:error "~~p expects a number argument")) (format:error "~~p expects a number argument"))
(if (= arg 1) (if (= arg 1)
(if (memq modifier '(at colon-at)) (when (memq modifier '(at colon-at))
(format:out-char #\y)) (format:out-char #\y))
(if (memq modifier '(at colon-at)) (if (memq modifier '(at colon-at))
(format:out-str "ies") (format:out-str "ies")
@ -383,14 +382,12 @@
((#\&) ; Fresh line ((#\&) ; Fresh line
(if (one-positive-integer? params) (if (one-positive-integer? params)
(begin (begin
(if (> (car params) 0) (when (> (car params) 0)
(format:out-fill (- (car params) (format:out-fill (- (car params)
(if (> (if (> output-col 0) 0 1))
output-col
0) 0 1))
#\newline)) #\newline))
(set! output-col 0)) (set! output-col 0))
(if (> output-col 0) (when (> output-col 0)
(format:out-char #\newline))) (format:out-char #\newline)))
(anychar-dispatch)) (anychar-dispatch))
((#\_) ; Space character ((#\_) ; Space character
@ -456,7 +453,7 @@
(set! flush-output? #t) (set! flush-output? #t)
(anychar-dispatch)) (anychar-dispatch))
((#\newline) ; Continuation lines ((#\newline) ; Continuation lines
(if (eq? modifier 'at) (when (eq? modifier 'at)
(format:out-char #\newline)) (format:out-char #\newline))
(if (< format:pos format-string-len) (if (< format:pos format-string-len)
(do ((ch (peek-next-char) (peek-next-char))) (do ((ch (peek-next-char) (peek-next-char)))
@ -475,8 +472,8 @@
(prev-arg)) (prev-arg))
(prev-arg))) (prev-arg)))
((at) ; jump absolute ((at) ; jump absolute
(set! arg-pos (if (one-positive-integer? params) (set! arg-pos
(car params) 0))) (if (one-positive-integer? params) (car params) 0)))
((colon-at) ((colon-at)
(format:error "illegal modifier `:@' in ~~* directive")) (format:error "illegal modifier `:@' in ~~* directive"))
(else ; jump forward (else ; jump forward
@ -495,7 +492,7 @@
(else string-downcase))) (else string-downcase)))
(anychar-dispatch)) (anychar-dispatch))
((#\)) ; Case conversion end ((#\)) ; Case conversion end
(if (not format:case-conversion) (unless format:case-conversion
(format:error "missing ~~(")) (format:error "missing ~~("))
(set! format:case-conversion #f) (set! format:case-conversion #f)
(anychar-dispatch)) (anychar-dispatch))
@ -518,11 +515,11 @@
(next-arg))))) (next-arg)))))
(anychar-dispatch)) (anychar-dispatch))
((#\;) ; Conditional separator ((#\;) ; Conditional separator
(if (zero? conditional-nest) (when (zero? conditional-nest)
(format:error "~~; not in ~~[~~] conditional")) (format:error "~~; not in ~~[~~] conditional"))
(if (not (null? params)) (unless (null? params)
(format:error "no parameter allowed in ~~;")) (format:error "no parameter allowed in ~~;"))
(if (= conditional-nest 1) (when (= conditional-nest 1)
(let ((clause-str (let ((clause-str
(cond (cond
((eq? modifier 'colon) ((eq? modifier 'colon)
@ -538,11 +535,12 @@
(set! clause-pos format:pos))) (set! clause-pos format:pos)))
(anychar-dispatch)) (anychar-dispatch))
((#\]) ; Conditional end ((#\]) ; Conditional end
(if (zero? conditional-nest) (format:error "missing ~~[")) (when (zero? conditional-nest)
(format:error "missing ~~["))
(set! conditional-nest (- conditional-nest 1)) (set! conditional-nest (- conditional-nest 1))
(if modifier (when modifier
(format:error "no modifier allowed in ~~]")) (format:error "no modifier allowed in ~~]"))
(if (not (null? params)) (unless (null? params)
(format:error "no parameter allowed in ~~]")) (format:error "no parameter allowed in ~~]"))
(cond (cond
((zero? conditional-nest) ((zero? conditional-nest)
@ -553,7 +551,7 @@
(set! clauses (append clauses (list clause-str))))) (set! clauses (append clauses (list clause-str)))))
(case conditional-type (case conditional-type
((if-then) ((if-then)
(if conditional-arg (when conditional-arg
(format:format-work (car clauses) (format:format-work (car clauses)
(list conditional-arg)))) (list conditional-arg))))
((if-else-then) ((if-else-then)
@ -563,11 +561,11 @@
(car clauses)) (car clauses))
(rest-args)))) (rest-args))))
((num-case) ((num-case)
(if (or (not (integer? conditional-arg)) (when (or (not (integer? conditional-arg))
(< conditional-arg 0)) (< conditional-arg 0))
(format:error "argument not a positive integer")) (format:error "argument not a positive integer"))
(if (not (and (>= conditional-arg (length clauses)) (unless (and (>= conditional-arg (length clauses))
(not clause-default))) (not clause-default))
(add-arg-pos (add-arg-pos
(format:format-work (format:format-work
(if (>= conditional-arg (length clauses)) (if (>= conditional-arg (length clauses))
@ -586,29 +584,31 @@
((colon) 'sublists) ((colon) 'sublists)
((colon-at) 'rest-sublists) ((colon-at) 'rest-sublists)
(else 'list))) (else 'list)))
(set! max-iterations (if (one-positive-integer? params) (set! max-iterations
(car params) #f)))) (if (one-positive-integer? params)
(car params)
#f))))
(anychar-dispatch)) (anychar-dispatch))
((#\}) ; Iteration end ((#\}) ; Iteration end
(if (zero? iteration-nest) (format:error "missing ~~{")) (when (zero? iteration-nest) (format:error "missing ~~{"))
(set! iteration-nest (- iteration-nest 1)) (set! iteration-nest (- iteration-nest 1))
(case modifier (case modifier
((colon) ((colon)
(if (not max-iterations) (set! max-iterations 1))) (unless max-iterations (set! max-iterations 1)))
((colon-at at) (format:error "illegal modifier"))) ((colon-at at) (format:error "illegal modifier")))
(if (not (null? params)) (unless (null? params)
(format:error "no parameters allowed in ~~}")) (format:error "no parameters allowed in ~~}"))
(if (zero? iteration-nest) (if (zero? iteration-nest)
(let ((iteration-str (let ((iteration-str
(substring format-string iteration-pos (substring format-string iteration-pos
(- format:pos (if modifier 3 2))))) (- format:pos (if modifier 3 2)))))
(if (string=? iteration-str "") (when (string=? iteration-str "")
(set! iteration-str (next-arg))) (set! iteration-str (next-arg)))
(case iteration-type (case iteration-type
((list) ((list)
(let ((args (next-arg)) (let ((args (next-arg))
(args-len 0)) (args-len 0))
(if (not (list? args)) (unless (list? args)
(format:error "expected a list argument")) (format:error "expected a list argument"))
(set! args-len (length args)) (set! args-len (length args))
(do ((arg-pos 0 (+ arg-pos (do ((arg-pos 0 (+ arg-pos
@ -622,7 +622,7 @@
((sublists) ((sublists)
(let ((args (next-arg)) (let ((args (next-arg))
(args-len 0)) (args-len 0))
(if (not (list? args)) (unless (list? args)
(format:error "expected a list argument")) (format:error "expected a list argument"))
(set! args-len (length args)) (set! args-len (length args))
(do ((arg-pos 0 (+ arg-pos 1))) (do ((arg-pos 0 (+ arg-pos 1)))
@ -630,9 +630,8 @@
(and max-iterations (and max-iterations
(>= arg-pos max-iterations)))) (>= arg-pos max-iterations))))
(let ((sublist (list-ref args arg-pos))) (let ((sublist (list-ref args arg-pos)))
(if (not (list? sublist)) (unless (list? sublist)
(format:error (format:error "expected a list of lists argument"))
"expected a list of lists argument"))
(format:format-work iteration-str sublist))))) (format:format-work iteration-str sublist)))))
((rest-args) ((rest-args)
(let* ((args (rest-args)) (let* ((args (rest-args))
@ -659,7 +658,7 @@
(>= arg-pos max-iterations))) (>= arg-pos max-iterations)))
arg-pos) arg-pos)
(let ((sublist (list-ref args arg-pos))) (let ((sublist (list-ref args arg-pos)))
(if (not (list? sublist)) (unless (list? sublist)
(format:error "expected list arguments")) (format:error "expected list arguments"))
(format:format-work iteration-str sublist))))) (format:format-work iteration-str sublist)))))
(add-arg-pos usedup-args))) (add-arg-pos usedup-args)))
@ -684,28 +683,30 @@
((>= arg-pos arg-len) ((>= arg-pos arg-len)
(set! format:pos format-string-len) #f) (set! format:pos format-string-len) #f)
(else #t)))) (else #t))))
(if continue (when continue
(anychar-dispatch)))) (anychar-dispatch))))
;; format directive modifiers and parameters ;; format directive modifiers and parameters
((#\@) ; `@' modifier ((#\@) ; `@' modifier
(if (memq modifier '(at colon-at)) (when (memq modifier '(at colon-at))
(format:error "double `@' modifier")) (format:error "double `@' modifier"))
(set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
(tilde-dispatch)) (tilde-dispatch))
((#\:) ; `:' modifier ((#\:) ; `:' modifier
(if (memq modifier '(colon colon-at)) (when (memq modifier '(colon colon-at))
(format:error "double `:' modifier")) (format:error "double `:' modifier"))
(set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
(tilde-dispatch)) (tilde-dispatch))
((#\') ; Character parameter ((#\') ; Character parameter
(if modifier (format:error "misplaced modifier")) (when modifier
(format:error "misplaced modifier"))
(set! params (append params (list (char->integer (next-char))))) (set! params (append params (list (char->integer (next-char)))))
(set! param-value-found #t) (set! param-value-found #t)
(tilde-dispatch)) (tilde-dispatch))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
(if modifier (format:error "misplaced modifier")) (when modifier
(format:error "misplaced modifier"))
(let ((num-str-beg (- format:pos 1)) (let ((num-str-beg (- format:pos 1))
(num-str-end format:pos)) (num-str-end format:pos))
(do ((ch (peek-next-char) (peek-next-char))) (do ((ch (peek-next-char) (peek-next-char)))
@ -721,19 +722,23 @@
(set! param-value-found #t) (set! param-value-found #t)
(tilde-dispatch)) (tilde-dispatch))
((#\V) ; Variable parameter from next argum. ((#\V) ; Variable parameter from next argum.
(if modifier (format:error "misplaced modifier")) (when modifier
(format:error "misplaced modifier"))
(set! params (append params (list (next-arg)))) (set! params (append params (list (next-arg))))
(set! param-value-found #t) (set! param-value-found #t)
(tilde-dispatch)) (tilde-dispatch))
((#\#) ; Parameter is number of remaining args ((#\#) ; Parameter is number of remaining args
(if param-value-found (format:error "misplaced '#'")) (when param-value-found
(if modifier (format:error "misplaced modifier")) (format:error "misplaced '#'"))
(when modifier
(format:error "misplaced modifier"))
(set! params (append params (list (length (rest-args))))) (set! params (append params (list (length (rest-args)))))
(set! param-value-found #t) (set! param-value-found #t)
(tilde-dispatch)) (tilde-dispatch))
((#\,) ; Parameter separators ((#\,) ; Parameter separators
(if modifier (format:error "misplaced modifier")) (when modifier
(if (not param-value-found) (format:error "misplaced modifier"))
(unless param-value-found
(set! params (append params '(#f)))) ; append empty paramtr (set! params (append params '(#f)))) ; append empty paramtr
(set! param-value-found #f) (set! param-value-found #f)
(tilde-dispatch)) (tilde-dispatch))
@ -802,17 +807,18 @@
(padchar (integer->char (padchar (integer->char
(format:par pars l 3 format:space-ch #f))) (format:par pars l 3 format:space-ch #f)))
(objstr (format:obj->str obj slashify))) (objstr (format:obj->str obj slashify)))
(if (not pad-left) (unless pad-left
(format:out-str objstr)) (format:out-str objstr))
(do ((objstr-len (string-length objstr)) (do ((objstr-len (string-length objstr))
(i minpad (+ i colinc))) (i minpad (+ i colinc)))
((>= (+ objstr-len i) mincol) ((>= (+ objstr-len i) mincol)
(format:out-fill i padchar))) (format:out-fill i padchar)))
(if pad-left (when pad-left
(format:out-str objstr)))))) (format:out-str objstr))))))
(define (format:out-num-padded modifier number pars radix) (define (format:out-num-padded modifier number pars radix)
(if (not (integer? number)) (format:error "argument not an integer")) (unless (integer? number)
(format:error "argument not an integer"))
(let ((numstr (number->string number radix))) (let ((numstr (number->string number radix)))
(if (and (null? pars) (not modifier)) (if (and (null? pars) (not modifier))
(format:out-str numstr) (format:out-str numstr)
@ -824,18 +830,18 @@
(commachar (integer->char (commachar (integer->char
(format:par pars l 2 (char->integer #\,) #f))) (format:par pars l 2 (char->integer #\,) #f)))
(commawidth (format:par pars l 3 3 "commawidth"))) (commawidth (format:par pars l 3 3 "commawidth")))
(if mincol (when mincol
(let ((numlen numstr-len)) ; calc. the output len of number (let ((numlen numstr-len)) ; calc. the output len of number
(if (and (memq modifier '(at colon-at)) (>= number 0)) (when (and (memq modifier '(at colon-at)) (>= number 0))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (memq modifier '(colon colon-at)) (when (memq modifier '(colon colon-at))
(set! numlen (+ (quotient (- numstr-len (set! numlen (+ (quotient (- numstr-len
(if (< number 0) 2 1)) (if (< number 0) 2 1))
commawidth) commawidth)
numlen))) numlen)))
(if (> mincol numlen) (when (> mincol numlen)
(format:out-fill (- mincol numlen) padchar)))) (format:out-fill (- mincol numlen) padchar))))
(if (and (memq modifier '(at colon-at)) (when (and (memq modifier '(at colon-at))
(>= number 0)) (>= number 0))
(format:out-char #\+)) (format:out-char #\+))
(if (memq modifier '(colon colon-at)) ; insert comma character (if (memq modifier '(colon colon-at)) ; insert comma character
@ -844,7 +850,7 @@
(format:out-substr numstr 0 start) (format:out-substr numstr 0 start)
(do ((i start (+ i commawidth))) (do ((i start (+ i commawidth)))
((>= i numstr-len)) ((>= i numstr-len))
(if (> i ns) (when (> i ns)
(format:out-char commachar)) (format:out-char commachar))
(format:out-substr numstr i (+ i commawidth)))) (format:out-substr numstr i (+ i commawidth))))
(format:out-str numstr))))))) (format:out-str numstr)))))))
@ -894,7 +900,8 @@
(let loop ((n n) (let loop ((n n)
(romans format:roman-alist) (romans format:roman-alist)
(s '())) (s '()))
(if (null? romans) (list->string (reverse s)) (if (null? romans)
(list->string (reverse s))
(let ((roman-val (caar romans)) (let ((roman-val (caar romans))
(roman-dgt (cadar romans))) (roman-dgt (cadar romans)))
(do ((q (quotient n roman-val) (- q 1)) (do ((q (quotient n roman-val) (- q 1))
@ -905,7 +912,8 @@
(format:error "only positive integers can be romanized"))) (format:error "only positive integers can be romanized")))
(define (format:num->roman n) (define (format:num->roman n)
(if (and (integer? n) (> n 0)) (unless (and (integer? n) (> n 0))
(format:error "only positive integers can be romanized"))
(let loop ((n n) (let loop ((n n)
(romans format:roman-alist) (romans format:roman-alist)
(boundaries format:roman-boundary-values) (boundaries format:roman-boundary-values)
@ -927,8 +935,7 @@
(cdr (assv bdry romans)) (cdr (assv bdry romans))
s))) s)))
(loop r (cdr romans) (cdr boundaries) s)) (loop r (cdr romans) (cdr boundaries) s))
(loop2 (- q 1) r (cons roman-dgt s))))))) (loop2 (- q 1) r (cons roman-dgt s))))))))
(format:error "only positive integers can be romanized")))
;; cardinals & ordinals (from dorai@cs.rice.edu) ;; cardinals & ordinals (from dorai@cs.rice.edu)
@ -1001,7 +1008,8 @@
(if (> n-after-block 0) (if (> n-after-block 0)
(append (append
(if (> n-before-block 0) (if (> n-before-block 0)
(string->list ", ") '()) (string->list ", ")
'())
(format:num->cardinal999 n-after-block) (format:num->cardinal999 n-after-block)
(if (< power3 power3-word-limit) (if (< power3 power3-word-limit)
(string->list (string->list
@ -1042,7 +1050,8 @@
(format:num->cardinal (* hundreds 100)) (format:num->cardinal (* hundreds 100))
(if (= tens+ones 0) "th" " ")) (if (= tens+ones 0) "th" " "))
"") "")
(if (= tens+ones 0) "" (if (= tens+ones 0)
""
(if (< tens+ones 20) (if (< tens+ones 20)
(list-ref format:ordinal-ones-list tens+ones) (list-ref format:ordinal-ones-list tens+ones)
(let ((tens (quotient tens+ones 10)) (let ((tens (quotient tens+ones 10))
@ -1082,7 +1091,7 @@
;; format fixed flonums (~F) ;; format fixed flonums (~F)
(define (format:out-fixed modifier number pars) (define (format:out-fixed modifier number pars)
(if (not (or (number? number) (string? number))) (unless (or (number? number) (string? number))
(format:error "argument is not a number or a number string")) (format:error "argument is not a number or a number string"))
(let ((l (length pars))) (let ((l (length pars)))
@ -1104,11 +1113,11 @@
(format:fn-round digits)) (format:fn-round digits))
(if width (if width
(let ((numlen (+ format:fn-len 1))) (let ((numlen (+ format:fn-len 1)))
(if (or (not format:fn-pos?) (eq? modifier 'at)) (when (or (not format:fn-pos?) (eq? modifier 'at))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (and (= format:fn-dot 0) (> width (+ digits 1))) (when (and (= format:fn-dot 0) (> width (+ digits 1)))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (< numlen width) (when (< numlen width)
(format:out-fill (- width numlen) (integer->char padch))) (format:out-fill (- width numlen) (integer->char padch)))
(if (and overch (> numlen width)) (if (and overch (> numlen width))
(format:out-fill width (integer->char overch)) (format:out-fill width (integer->char overch))
@ -1120,11 +1129,11 @@
(format:fn-strip) (format:fn-strip)
(if width (if width
(let ((numlen (+ format:fn-len 1))) (let ((numlen (+ format:fn-len 1)))
(if (or (not format:fn-pos?) (eq? modifier 'at)) (when (or (not format:fn-pos?) (eq? modifier 'at))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (= format:fn-dot 0) (when (= format:fn-dot 0)
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (< numlen width) (when (< numlen width)
(format:out-fill (- width numlen) (integer->char padch))) (format:out-fill (- width numlen) (integer->char padch)))
(if (> numlen width) ; adjust precision if possible (if (> numlen width) ; adjust precision if possible
(let ((dot-index (- numlen (let ((dot-index (- numlen
@ -1142,7 +1151,7 @@
;; format exponential flonums (~E) ;; format exponential flonums (~E)
(define (format:out-expon modifier number pars) (define (format:out-expon modifier number pars)
(if (not (or (number? number) (string? number))) (unless (or (number? number) (string? number))
(format:error "argument is not a number")) (format:error "argument is not a number"))
(let ((l (length pars))) (let ((l (length pars)))
@ -1174,16 +1183,16 @@
(if (and edigits overch (> format:en-len edigits)) (if (and edigits overch (> format:en-len edigits))
(format:out-fill width (integer->char overch)) (format:out-fill width (integer->char overch))
(let ((numlen (+ format:fn-len 3))) ; .E+ (let ((numlen (+ format:fn-len 3))) ; .E+
(if (or (not format:fn-pos?) (eq? modifier 'at)) (when (or (not format:fn-pos?) (eq? modifier 'at))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (and (= format:fn-dot 0) (> width (+ digits 1))) (when (and (= format:fn-dot 0) (> width (+ digits 1)))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(set! numlen (set! numlen
(+ numlen (+ numlen
(if (and edigits (>= edigits format:en-len)) (if (and edigits (>= edigits format:en-len))
edigits edigits
format:en-len))) format:en-len)))
(if (< numlen width) (when (< numlen width)
(format:out-fill (- width numlen) (format:out-fill (- width numlen)
(integer->char padch))) (integer->char padch)))
(if (and overch (> numlen width)) (if (and overch (> numlen width))
@ -1202,16 +1211,16 @@
(if (and edigits overch (> format:en-len edigits)) (if (and edigits overch (> format:en-len edigits))
(format:out-fill width (integer->char overch)) (format:out-fill width (integer->char overch))
(let ((numlen (+ format:fn-len 3))) ; .E+ (let ((numlen (+ format:fn-len 3))) ; .E+
(if (or (not format:fn-pos?) (eq? modifier 'at)) (when (or (not format:fn-pos?) (eq? modifier 'at))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (= format:fn-dot 0) (when (= format:fn-dot 0)
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(set! numlen (set! numlen
(+ numlen (+ numlen
(if (and edigits (>= edigits format:en-len)) (if (and edigits (>= edigits format:en-len))
edigits edigits
format:en-len))) format:en-len)))
(if (< numlen width) (when (< numlen width)
(format:out-fill (- width numlen) (format:out-fill (- width numlen)
(integer->char padch))) (integer->char padch)))
(if (> numlen width) ; adjust precision if possible (if (> numlen width) ; adjust precision if possible
@ -1237,7 +1246,7 @@
;; format general flonums (~G) ;; format general flonums (~G)
(define (format:out-general modifier number pars) (define (format:out-general modifier number pars)
(if (not (or (number? number) (string? number))) (unless (or (number? number) (string? number))
(format:error "argument is not a number or a number string")) (format:error "argument is not a number or a number string"))
(let ((l (length pars))) (let ((l (length pars)))
@ -1272,7 +1281,7 @@
;; format dollar flonums (~$) ;; format dollar flonums (~$)
(define (format:out-dollar modifier number pars) (define (format:out-dollar modifier number pars)
(if (not (or (number? number) (string? number))) (unless (or (number? number) (string? number))
(format:error "argument is not a number or a number string")) (format:error "argument is not a number or a number string"))
(let ((l (length pars))) (let ((l (length pars)))
@ -1292,16 +1301,16 @@
(format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
(format:fn-round digits)) (format:fn-round digits))
(let ((numlen (+ format:fn-len 1))) (let ((numlen (+ format:fn-len 1)))
(if (or (not format:fn-pos?) (memq modifier '(at colon-at))) (when (or (not format:fn-pos?) (memq modifier '(at colon-at)))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (and mindig (> mindig format:fn-dot)) (when (and mindig (> mindig format:fn-dot))
(set! numlen (+ numlen (- mindig format:fn-dot)))) (set! numlen (+ numlen (- mindig format:fn-dot))))
(if (and (= format:fn-dot 0) (not mindig)) (when (and (= format:fn-dot 0) (not mindig))
(set! numlen (+ numlen 1))) (set! numlen (+ numlen 1)))
(if (< numlen width) (if (< numlen width)
(case modifier (case modifier
((colon) ((colon)
(if (not format:fn-pos?) (unless format:fn-pos?
(format:out-char #\-)) (format:out-char #\-))
(format:out-fill (- width numlen) (integer->char padch))) (format:out-fill (- width numlen) (integer->char padch)))
((at) ((at)
@ -1312,14 +1321,15 @@
(format:out-fill (- width numlen) (integer->char padch))) (format:out-fill (- width numlen) (integer->char padch)))
(else (else
(format:out-fill (- width numlen) (integer->char padch)) (format:out-fill (- width numlen) (integer->char padch))
(if (not format:fn-pos?) (unless format:fn-pos?
(format:out-char #\-)))) (format:out-char #\-))))
(if format:fn-pos? (if format:fn-pos?
(if (memq modifier '(at colon-at)) (format:out-char #\+)) (when (memq modifier '(at colon-at))
(format:out-char #\+))
(format:out-char #\-)))) (format:out-char #\-))))
(if (and mindig (> mindig format:fn-dot)) (when (and mindig (> mindig format:fn-dot))
(format:out-fill (- mindig format:fn-dot) #\0)) (format:out-fill (- mindig format:fn-dot) #\0))
(if (and (= format:fn-dot 0) (not mindig)) (when (and (= format:fn-dot 0) (not mindig))
(format:out-char #\0)) (format:out-char #\0))
(format:out-substr format:fn-str 0 format:fn-dot) (format:out-substr format:fn-str 0 format:fn-dot)
(format:out-char #\.) (format:out-char #\.)
@ -1353,21 +1363,20 @@
(num-len (string-length num-str)) (num-len (string-length num-str))
(c #f)) ; current exam. character in num-str (c #f)) ; current exam. character in num-str
((= i num-len) ((= i num-len)
(if (not format:fn-dot) (unless format:fn-dot
(set! format:fn-dot format:fn-len)) (set! format:fn-dot format:fn-len))
(if all-zeros? (when all-zeros?
(begin
(set! left-zeros 0) (set! left-zeros 0)
(set! format:fn-dot 0) (set! format:fn-dot 0)
(set! format:fn-len 1))) (set! format:fn-len 1))
;; now format the parsed values according to format's need ;; now format the parsed values according to format's need
(if fixed? (if fixed?
(begin ; fixed format m.nnn or .nnn (begin ; fixed format m.nnn or .nnn
(if (and (> left-zeros 0) (> format:fn-dot 0)) (when (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 (begin ; norm 0{0}nn.mm to nn.mm
(format:fn-shiftleft left-zeros) (format:fn-shiftleft left-zeros)
@ -1377,7 +1386,7 @@
(format:fn-shiftleft format:fn-dot) (format:fn-shiftleft format:fn-dot)
(set! left-zeros (- left-zeros format:fn-dot)) (set! left-zeros (- left-zeros format:fn-dot))
(set! format:fn-dot 0)))) (set! format:fn-dot 0))))
(if (or (not (= scale 0)) (> format:en-len 0)) (when (or (not (= scale 0)) (> format:en-len 0))
(let ((shift (+ scale (format:en-int)))) (let ((shift (+ scale (format:en-int))))
(cond (cond
(all-zeros? #t) (all-zeros? #t)
@ -1405,7 +1414,7 @@
(begin ; normalize 0{0}.nnn to n.nn (begin ; normalize 0{0}.nnn to n.nn
(format:fn-shiftleft left-zeros) (format:fn-shiftleft left-zeros)
(set! format:fn-dot 1)) (set! format:fn-dot 1))
(if (= format:fn-dot 0) (when (= format:fn-dot 0)
(set! format:fn-dot 1))) (set! format:fn-dot 1)))
(format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
negexp)) negexp))
@ -1430,7 +1439,7 @@
(if mantissa? ; complex numbers (if mantissa? ; complex numbers
(begin (begin
(if (char=? c #\0) (if (char=? c #\0)
(if all-zeros? (when all-zeros?
(set! left-zeros (+ left-zeros 1))) (set! left-zeros (+ left-zeros 1)))
(begin (begin
(set! all-zeros? #f))) (set! all-zeros? #f)))
@ -1476,13 +1485,12 @@
(c #f)) (c #f))
((= i en-len)) ((= i en-len))
(set! c (string-ref en-str i)) (set! c (string-ref en-str i))
(if (char-numeric? c) (when (char-numeric? c)
(begin
(string-set! format:en-str format:en-len c) (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))))))
(define (format:fn-zfill left? n) ; fill current number string with 0s (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 (when (> (+ n format:fn-len) format:fn-max) ; from the left or right
(format:error "number is too long to format (enlarge format:fn-max)")) (format:error "number is too long to format (enlarge format:fn-max)"))
(set! format:fn-len (+ format:fn-len n)) (set! format:fn-len (+ format:fn-len n))
(if left? (if left?
@ -1497,7 +1505,7 @@
(string-set! format:fn-str i #\0)))) (string-set! format:fn-str i #\0))))
(define (format:fn-shiftleft n) ; shift left current number n positions (define (format:fn-shiftleft n) ; shift left current number n positions
(if (> n format:fn-len) (when (> n format:fn-len)
(format:error "internal error in format:fn-shiftleft (~d,~d)" (format:error "internal error in format:fn-shiftleft (~d,~d)"
n format:fn-len)) n format:fn-len))
(do ((i n (+ i 1))) (do ((i n (+ i 1)))
@ -1527,11 +1535,11 @@
(define (format:fn-out modifier add-leading-zero?) (define (format:fn-out modifier add-leading-zero?)
(if format:fn-pos? (if format:fn-pos?
(if (eq? modifier 'at) (when (eq? modifier 'at)
(format:out-char #\+)) (format:out-char #\+))
(format:out-char #\-)) (format:out-char #\-))
(if (= format:fn-dot 0) (if (= format:fn-dot 0)
(if add-leading-zero? (when add-leading-zero?
(format:out-char #\0)) (format:out-char #\0))
(format:out-substr format:fn-str 0 format:fn-dot)) (format:out-substr format:fn-str 0 format:fn-dot))
(format:out-char #\.) (format:out-char #\.)
@ -1540,9 +1548,8 @@
(define (format:en-out edigits expch) (define (format:en-out edigits expch)
(format:out-char (if expch (integer->char expch) #\E)) (format:out-char (if expch (integer->char expch) #\E))
(format:out-char (if format:en-pos? #\+ #\-)) (format:out-char (if format:en-pos? #\+ #\-))
(if edigits (when (and edigits (< format:en-len edigits))
(if (< format:en-len edigits) (format:out-fill (- edigits format:en-len) #\0))
(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))
(define (format:fn-strip) ; strip trailing zeros but one (define (format:fn-strip) ; strip trailing zeros but one
@ -1570,7 +1577,7 @@
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((= i str-len) cap-str) ((= i str-len) cap-str)
(let ((c (string-ref str i))) (let ((c (string-ref str i)))
(if (char-alphabetic? c) (when (char-alphabetic? c)
(if non-first-alpha (if non-first-alpha
(string-set! cap-str i (char-downcase c)) (string-set! cap-str i (char-downcase c))
(begin (begin
@ -1590,7 +1597,7 @@
(display format:arg-pos) (display format:arg-pos)
(format:error "~a missing argument~:p" (- arg-pos arg-len))) (format:error "~a missing argument~:p" (- arg-pos arg-len)))
(else (else
(if flush-output? (when flush-output?
(force-output port)) (force-output port))
(if destination (if destination
#t #t