This page is part of the web mail archives of SRFI 48 from before July 7th, 2015. The new archives for SRFI 48 contain all messages, not just those from before July 7th, 2015.
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