[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: floating point and other comments
On Mon, Dec 22, 2003 at 11:23:19PM -0600, Alex Shinn wrote:
> Ugh, no it wasn't, it was a very sloppy rip-off of my previous code
> which introduced several bugs. The ~A fix was also broken. I
> apologize for the poor code and attach a new version.
Attached for real this time.
--
Alex
;; IMPLEMENTATION DEPENDENT options
(define ascii-tab (integer->char 9)) ;; Assume ASCII encoding
(define dont-print (if (eq? #t #f) 1)) ;; Unspecified result
;;(define DONT-PRINT (string->symbol ""))
;;(define DONT-PRINT (void))
(define pretty-print display) ;; Ugly, but permitted
;; FORMAT
(define (format . args)
(cond
((null? args)
(error "FORMAT: required format-string argument is missing")
)
((string? (car args))
(apply format (cons #f args)))
((< (length args) 2)
(error (format #f "FORMAT: too few arguments ~a" (cons 'format args)))
)
(else
(let ( (output-port (car args))
(format-string (cadr args))
(args (cddr args))
)
(letrec ( (port
(cond ((output-port? output-port) output-port)
((eq? output-port #t) (current-output-port))
((eq? output-port #f) (open-output-string))
(else (error
(format #f "FORMAT: bad output-port argument: ~s"
output-port)))
))
(return-value
(if (eq? output-port #f) ;; if format into a string
(lambda () (get-output-string port)) ;; then return the string
(lambda () dont-print)) ;; else do something harmless
)
)
(define (round* n scale) ;; assume scale < 0
(let ((one (expt 10 (- scale))))
(/ (round (* n one)) one)))
(define (string-index str c)
(let ((len (string-length str)))
(let loop ((i 0))
(cond ((= i len) #f)
((eqv? c (string-ref str i)) i)
(else (loop (+ i 1)))))))
(define (string-grow str len char)
(let ((off (- len (string-length str))))
(if (positive? off)
(string-append (make-string off char) str)
str)))
(define (string-pad-right str len char)
(let ((slen (string-length str)))
(cond ((< slen len)
(string-append str (make-string (- len slen) char)))
((> slen len)
(substring str 0 len))
(else str))))
(define (format-fixed num width digits)
((if width (lambda (s) (string-grow s width #\space))
(lambda (s) s))
(let ((real (real-part num))
(imag (imag-part num)))
(cond
((not (zero? imag))
(string-append (format-fixed real #f digits)
(if (negative? imag) "" "+")
(format-fixed imag #f digits)
"i"))
(digits
(let* ((n1 (exact->inexact (round* real (- digits))))
(s1 (number->string n1))
(d1 (string-index s1 #\.))
(s2 (if d1 s1 (string-append s1 ".0")))
(d2 (string-index s2 #\.))
(l2 (string-length s2))
(s3 (substring s2 (+ d2 1) l2)))
(string-append (substring s2 0 (+ d2 1))
(string-pad-right s3 digits #\0))))
(else (number->string num))))))
(define (format-help format-strg arglist)
(letrec (
(length-of-format-string (string-length format-strg))
(anychar-dispatch
(lambda (pos arglist last-was-newline)
(if (>= pos length-of-format-string)
arglist ; used for ~? continuance
(let ( (char (string-ref format-strg pos)) )
(cond
((eq? char #\~)
(tilde-dispatch (+ pos 1) arglist '() '() last-was-newline))
(else
(write-char char port)
(anychar-dispatch (+ pos 1) arglist #f)
))
))
)) ; end anychar-dispatch
(collect-digits
(lambda (digits)
(and (pair? digits)
(string->number (list->string (reverse digits))))))
(tilde-dispatch
(lambda (pos arglist params digits last-was-newline)
(cond
((>= pos length-of-format-string)
(write-char #\~ port) ; tilde at end of string is just output
arglist ; used for ~? continuance
)
(else
(case (char-upcase (string-ref format-strg pos))
((#\A) ; Any -- for humans
(let* ((x (car arglist))
(nl? (if (string? x)
(if (string=? x "") last-was-newline
(eqv? #\newline (string-ref x (- (string-length x) 1))))
(eqv? x #\newline))))
(display x port)
(anychar-dispatch (+ pos 1) (cdr arglist) nl?))
)
((#\S) ; Slashified -- for parsers
(write (car arglist) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\D) ; Decimal
(display (number->string (car arglist) 10) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\X) ; HeXadecimal
(display (number->string (car arglist) 16) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\O) ; Octal
(display (number->string (car arglist) 8) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\B) ; Binary
(display (number->string (car arglist) 2) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\C) ; Character
(write-char (car arglist) port)
(anychar-dispatch (+ pos 1) (cdr arglist) (eq? (car arglist) #\newline))
)
((#\P) ; Plural
(if (<= (car arglist) 1)
#f ; no action
(write-char #\s port))
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\~) ; Tilde
(write-char #\~ port)
(anychar-dispatch (+ pos 1) arglist #f)
)
((#\%) ; Newline
(newline port)
(anychar-dispatch (+ pos 1) arglist #t)
)
((#\&) ; Freshline
(if (not last-was-newline) ;; (unless last-was-newline ..
(newline port))
(anychar-dispatch (+ pos 1) arglist #t)
)
((#\_) ; Space
(write-char #\space port)
(anychar-dispatch (+ pos 1) arglist #f)
)
((#\T) ; Tab -- IMPLEMENTATION DEPENDENT ENCODING
(write-char #\tab port)
(anychar-dispatch (+ pos 1) arglist #f)
)
((#\Y) ; Pretty-print
(pretty-print (car arglist) port) ;; IMPLEMENTATION DEPENDENT
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
;; {"~?" in Common Lisp is "~K" in T}
((#\? #\K) ; indirection -- take next arg as format string
(anychar-dispatch
(+ pos 1)
(format-help (car arglist) (cdr arglist)) ; Note: format-help returns unused args
#f)
)
((#\F)
(let* ((plist (reverse (cons (collect-digits digits) params)))
(width (and (pair? plist) (car plist)))
(digits (and (pair? plist) (pair? (cdr plist)) (cadr plist))))
(display (format-fixed (car arglist) width digits) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)))
((#\,)
(tilde-dispatch (+ pos 1) arglist (cons (collect-digits digits) params)
'() last-was-newline))
((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\+ #\-)
(tilde-dispatch (+ pos 1) arglist params
(cons (string-ref format-strg pos) digits)
last-was-newline))
(else
(error (format "FORMAT: unknown tilde escape: ~a"
(string-ref format-strg pos))))
)))
)) ; end tilde-dispatch
) ; end letrec
; format-help main
(anychar-dispatch 0 arglist #f)
)) ; end format-help
; format main
(format-help format-string args)
(return-value)
)) ; end letrec, if
))) ; end format