format.scm

MSYS在windows下模拟了一个类unix的终端

			  (if (< scale (+ digits 2))
			      (+ (- digits scale) 1)
			      0)
			  digits)))
	  (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)))
	      (format:fn-round digits))
	  (if width
	      (if (and edigits overch (> format:en-len edigits))
		  (format:out-fill width (integer->char overch))
		  (let ((numlen (+ format:fn-len 3))) ; .E+
		    (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 
			     (if (and edigits (>= edigits format:en-len))
				 edigits 
				 format:en-len)))
		    (if (< numlen width)
			(format:out-fill (- width numlen)
					 (integer->char padch)))
		    (if (and overch (> numlen width))
			(format:out-fill width (integer->char overch))
			(begin
			  (format:fn-out modifier (> width (- numlen 1)))
			  (format:en-out edigits expch)))))
	      (begin
		(format:fn-out modifier #t)
		(format:en-out edigits expch))))

	(begin				; free precision
	  (format:parse-float
	   (if (string? number) number (number->string number)) #f scale)
	  (format:fn-strip)
	  (if width
	      (if (and edigits overch (> format:en-len edigits))
		  (format:out-fill width (integer->char overch))
		  (let ((numlen (+ format:fn-len 3))) ; .E+
		    (if (or (not format:fn-pos?) (eq? modifier 'at))
			(set! numlen (+ numlen 1)))
		    (if (= format:fn-dot 0)
			(set! numlen (+ numlen 1)))
		    (set! numlen
			  (+ numlen
			     (if (and edigits (>= edigits format:en-len))
				 edigits 
				 format:en-len)))
		    (if (< numlen width)
			(format:out-fill (- width numlen)
					 (integer->char padch)))
		    (if (> numlen width) ; adjust precision if possible
			(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 
						   (integer->char overch))
				  (begin
				    (format:fn-out modifier #t)
				    (format:en-out edigits expch)))
			      (begin
				(format:fn-round (+ (- f numlen) width))
				(format:fn-out modifier #t)
				(format:en-out edigits expch))))
			(begin
			  (format:fn-out modifier #t)
			  (format:en-out edigits expch)))))
	      (begin
		(format:fn-out modifier #t)
		(format:en-out edigits expch))))))))
	
;; format general flonums (~G)

(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"))

  (let ((l (length pars)))
    (let ((width (if (> l 0) (list-ref pars 0) #f))
	  (digits (if (> l 1) (list-ref pars 1) #f))
	  (edigits (if (> l 2) (list-ref pars 2) #f))
	  (overch (if (> l 4) (list-ref pars 4) #f))
	  (padch (if (> l 5) (list-ref pars 5) #f)))
    (format:parse-float
     (if (string? number) number (number->string number)) #t 0)
    (format:fn-strip)
    (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
	   (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
	   (n (if (= format:fn-dot 0)	; number less than (abs 1.0) ?
		  (- (format:fn-zlead))
		  format:fn-dot))
	   (d (if digits
		  digits
		  (max format:fn-len (min n 7)))) ; q = format:fn-len
	   (dd (- d n)))
      (if (<= 0 dd d)
	  (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 dollar flonums (~$)

(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"))

  (let ((l (length pars)))
    (let ((digits (format:par pars l 0 2 "digits"))
	  (mindig (format:par pars l 1 1 "mindig"))
	  (width (format:par pars l 2 0 "width"))
	  (padch (format:par pars l 3 format:space-ch #f)))

    (format:parse-float
     (if (string? number) number (number->string number)) #t 0)
    (if (<= (- format:fn-len format:fn-dot) digits)
	(format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
	(format:fn-round digits))
    (let ((numlen (+ format:fn-len 1)))
      (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
	  (set! numlen (+ numlen 1)))
      (if (and mindig (> mindig format:fn-dot))
	  (set! numlen (+ numlen (- mindig format:fn-dot))))
      (if (and (= format:fn-dot 0) (not mindig))
	  (set! numlen (+ numlen 1)))
      (if (< numlen width)
	  (case modifier
	    ((colon)
	     (if (not format:fn-pos?)
		 (format:out-char #\-))
	     (format:out-fill (- width numlen) (integer->char padch)))
	    ((at)
	     (format:out-fill (- width numlen) (integer->char padch))
	     (format:out-char (if format:fn-pos? #\+ #\-)))
	    ((colon-at)
	     (format:out-char (if format:fn-pos? #\+ #\-))
	     (format:out-fill (- width numlen) (integer->char padch)))
	    (else
	     (format:out-fill (- width numlen) (integer->char padch))
	     (if (not format:fn-pos?)
		 (format:out-char #\-))))
	  (if format:fn-pos?
	      (if (memq modifier '(at colon-at)) (format:out-char #\+))
	      (format:out-char #\-))))
    (if (and mindig (> mindig format:fn-dot))
	(format:out-fill (- mindig format:fn-dot) #\0))
    (if (and (= format:fn-dot 0) (not mindig))
	(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))))

; the flonum buffers

(define format:fn-max 200)		; max. number of number digits
(define format:fn-str (make-string format:fn-max)) ; 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 (make-string format:en-max)) ; exponent buffer
(define format:en-len 0)		; digit length of exponent
(define format:en-pos? #t)		; exponent positive?

(define (format:parse-float num-str fixed? scale)
  (set! format:fn-pos? #t)
  (set! format:fn-len 0)
  (set! format:fn-dot #f)
  (set! format:en-pos? #t)
  (set! format:en-len 0)
  (do ((i 0 (+ i 1))
       (left-zeros 0)
       (mantissa? #t)
       (all-zeros? #t)
       (num-len (string-length num-str))
       (c #f))			; current exam. character in num-str
      ((= i num-len)
       (if (not format:fn-dot)
	   (set! format:fn-dot format:fn-len))

       (if all-zeros?
	   (begin
	     (set! left-zeros 0)
	     (set! format:fn-dot 0)
	     (set! format:fn-len 1)))

       ;; now format the parsed values according to format's need

       (if fixed?

	   (begin			; fixed format m.nnn or .nnn
	     (if (and (> left-zeros 0) (> format:fn-dot 0))
		 (if (> format:fn-dot left-zeros) 
		     (begin		; norm 0{0}nn.mm to nn.mm
		       (format:fn-shiftleft left-zeros)
		       (set! left-zeros 0)
		       (set! format:fn-dot (- format:fn-dot left-zeros)))
		     (begin		; normalize 0{0}.nnn to .nnn
		       (format:fn-shiftleft format:fn-dot)
		       (set! left-zeros (- left-zeros format:fn-dot))
		       (set! format:fn-dot 0))))
	     (if (or (not (= scale 0)) (> format:en-len 0))
		 (let ((shift (+ scale (format:en-int))))
		   (cond
		    (all-zeros? #t)
		    ((> (+ format:fn-dot shift) format:fn-len)
		     (format:fn-zfill
		      #f (- shift (- format:fn-len format:fn-dot)))
		     (set! format:fn-dot format:fn-len))
		    ((< (+ format:fn-dot shift) 0)
		     (format:fn-zfill #t (- (- shift) format:fn-dot))
		     (set! format:fn-dot 0))
		    (else
		     (if (> left-zeros 0)
			 (if (<= left-zeros shift) ; shift always > 0 here
			     (format:fn-shiftleft shift) ; shift out 0s
			     (begin
			       (format:fn-shiftleft left-zeros)
			       (set! format:fn-dot (- shift left-zeros))))
			 (set! format:fn-dot (+ format:fn-dot shift))))))))

	   (let ((negexp		; expon format m.nnnEee
		  (if (> left-zeros 0)
		      (- left-zeros format:fn-dot -1)
		      (if (= format:fn-dot 0) 1 0))))
	     (if (> left-zeros 0)
		 (begin			; normalize 0{0}.nnn to n.nn
		   (format:fn-shiftleft left-zeros)
		   (set! format:fn-dot 1))
		 (if (= format:fn-dot 0)
		     (set! format:fn-dot 1)))
	     (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
			       negexp))
	     (cond 
	      (all-zeros?
	       (format:en-set 0)
	       (set! format:fn-dot 1))
	      ((< scale 0)		; leading zero
	       (format:fn-zfill #t (- scale))
	       (set! format:fn-dot 0))
	      ((> scale format:fn-dot)
	       (format:fn-zfill #f (- scale format:fn-dot))
	       (set! format:fn-dot scale))
	      (else
	       (set! format:fn-dot scale)))))
       #t)

    ;; 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 
      (if mantissa?			; complex numbers
	  (begin
	    (if (char=? c #\0)
		(if all-zeros?
		    (set! left-zeros (+ left-zeros 1)))
		(begin
		  (set! all-zeros? #f)))
	    (string-set! format:fn-str format:fn-len c)
	    (set! format:fn-len (+ format:fn-len 1)))
	  (begin
	    (string-set! format:en-str format:en-len c)
	    (set! format:en-len (+ format:en-len 1)))))
     ((or (char=? c #\-) (char=? c #\+))
      (if mantissa?
	  (set! format:fn-pos? (char=? c #\+))
	  (set! format:en-pos? (char=? c #\+))))
     ((char=? c #\.)
      (set! format:fn-dot format:fn-len))
     ((char=? c #\e)
      (set! mantissa? #f))
     ((char=? c #\E)
      (set! mantissa? #f))
     ((char-whitespace? c) #t)
     ((char=? c #\d) #t)		; decimal radix prefix
     ((char=? c #\#) #t)
     (else
      (format:error "illegal character `~c' in number->string" c)))))

(define (format:en-int)			; convert exponent string to integer
  (if (= format:en-len 0)
      0
      (do ((i 0 (+ i 1))
	   (n 0))
	  ((= i format:en-len) 
	   (if format:en-pos?
	       n
	       (- n)))
	(set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
			       format:zero-ch))))))

(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)))
    (do ((i 0 (+ i 1))
	 (en-len (string-length en-str))
	 (c #f))
	((= i en-len))
      (set! c (string-ref en-str i))
      (if (char-numeric? c)
	  (begin
	    (string-set! format:en-str format:en-len c)
	    (set! format:en-len (+ format:en-len 1)))))))

(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))
  (if left?
      (do ((i format:fn-len (- i 1)))	; fill n 0s to left
	  ((< i 0))
	(string-set! format:fn-str i
		     (if (< i n)
			 #\0
			 (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))))

(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))))

(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"
      ((or (= c 0) (< i 0))		; "999",2 -> "100"
       (if (= c 1)			; "005",2 -> "01"
	   (begin			; carry overflow
	     (set! format:fn-len digits)
	     (format:fn-zfill #t 1)	; add a 1 before fn-str
	     (string-set! format:fn-str 0 #\1)
	     (set! format:fn-dot (+ format:fn-dot 1)))
	   (set! format:fn-len digits)))
    (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) 
				      (+ 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) 
	  (format:out-char #\+))
      (format:out-char #\-))
  (if (= format:fn-dot 0)
      (if add-leading-zero?
	  (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))

(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 (< format:en-len edigits)
	  (format:out-fill (- edigits format:en-len) #\0)))
  (format:out-substr format:en-str 0 format:en-len))

(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)))))

(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))))


;;; some global functions not found in SLIB

(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"
    (do ((i 0 (+ i 1)))
	((= i str-len) cap-str)
      (let ((c (string-ref str i)))
	(if (char-alphabetic? c)
	    (if non-first-alpha
		(string-set! cap-str i (char-downcase c))
		(begin
		  (set! non-first-alpha #t)
		  (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.

(define format:abort (lambda () (error "error in format")))

(define format format:format)
;; Thanks to Shuji Narazaki
(module-set! the-root-module 'format format)

;; If this is not possible then a continuation is used to recover
;; properly from a format error. In this case format returns #f.

;(define format:abort
;  (lambda () (format:error-continuation #f)))

;(define format
;  (lambda args				; wraps format:format with an error
;    (call-with-current-continuation	; continuation
;     (lambda (cont)
;       (set! format:error-continuation cont)
;       (apply format:format args)))))

;eof