Formatted Output

April 8, 2014

The sprintf function is shown below in its entirety. It processes the fmt string as a list of characters one-by-one from left-to-right, calling the local functions escape to process escape sequences and specifier to process format specifiers. Both escape and specifier take the current remaining fmt string, extract the appropriate portion of the head of the string, and return both a value and the remaining fmt string. The escape function looks at the next character after the backslash; the specifier function extracts modifiers in turn, then handles the single-character specifier. Errors are signalled if anything goes wrong.

(define (sprintf fmt . args)
  (define (escape cs)
    (define (octal? c) (char<=? #\0 c #\7))
    (define (c->o c) (- (char->integer c) 48))
    (cond ((null? cs) (error 'escape "incomplete"))
          ((not (char=? (car cs) #\\)) (values (car cs) (cdr cs)))
          ((null? (cdr cs)) (error 'escape "malformed"))
          ((char=? (cadr cs) #\b) (values #\backspace (cddr cs)))
          ((char=? (cadr cs) #\f) (values #\page (cddr cs)))
          ((char=? (cadr cs) #\n) (values #\newline (cddr cs)))
          ((char=? (cadr cs) #\r) (values #\return (cddr cs)))
          ((char=? (cadr cs) #\t) (values #\tab (cddr cs)))
          ((octal? (cadr cs))
            (let loop ((k 3) (cs (cdr cs)) (oct 0))
              (if (and (positive? k) (pair? cs) (octal? (car cs)))
                  (loop (- k 1) (cdr cs) (+ (* oct 8) (c->o (car cs))))
                  (values (integer->char oct) cs))))
          (else (values (cadr cs) (cddr cs)))))
  (define (specifier cs arg)
    (define (c->d c) (- (char->integer c) 48))
    (define (justify str left? pad? width)
      (let ((len (string-length str)))
        (cond ((<= width len) str)
              (left? (string-append str (make-string (- width len) #\space)))
              ((and pad? (not left?)) (string-append (make-string (- width len) #\0) str))
              (else (string-append (make-string (- width len) #\space) str)))))
    (define (rnd num prec)
        (if prec (/ (round (* num (expt 10 prec))) (expt 10 prec)) num))
    (define (trunc num) (inexact->exact (truncate num)))
    (let ((cs (cdr cs)) (left? #f) (pad? #f) (width 0) (prec #f))
      (when (and (pair? cs) (char=? (car cs) #\-))
        (set! left? #t) (set! cs (cdr cs)))
      (when (and (pair? cs) (char=? (car cs) #\0))
        (set! pad? #t) (set! cs (cdr cs)))
      (do () ((or (null? cs) (not (char-numeric? (car cs)))))
        (set! width (+ (* width 10) (c->d (car cs)))) (set! cs (cdr cs)))
      (when (and (pair? cs) (char=? (car cs) #\.))
        (set! cs (cdr cs)) (set! prec 0)
        (do () ((or (null? cs) (not (char-numeric? (car cs)))))
          (set! prec (+ (* prec 10) (c->d (car cs)))) (set! cs (cdr cs))))
      (if (null? cs) (error 'specifier "incomplete")
        (case (car cs)
        ((#\c) (values (justify (string (integer->char arg)) left? #f width) (cdr cs)))
        ((#\d) (values (justify (number->string (trunc arg)) left? pad? width) (cdr cs)))
        ((#\f) (values (justify (number->string (rnd arg prec)) left? pad? width) (cdr cs)))
        ((#\o) (values (justify (number->string (trunc arg) 8) left? pad? width) (cdr cs)))
        ((#\s) (values (justify (if prec (substring arg 0 prec) arg) left? #f width) (cdr cs)))
        ((#\x) (values (justify (number->string (trunc arg) 16) left? pad? width) (cdr cs)))
        (else (error 'specifier "unsupported"))))))
  (let loop ((cs (string->list fmt)) (args args) (out (list)))
    (cond ((null? cs)
            (if (pair? args) (error 'printf "too many arguments")
              (list->string (reverse out))))
          ((char=? (car cs) #\\)
            (call-with-values (lambda () (escape cs))
              (lambda (c rest) (loop rest args (cons c out)))))
          ((char=? (car cs) #\%)
            (if (null? (cdr cs)) (error 'sprintf "incomplete specifier")
              (if (char=? (cadr cs) #\%) (loop (cddr cs) args (cons #\% out))
                (if (null? args) (error 'printf "not enough arguments")
                  (call-with-values (lambda () (specifier cs (car args)))
                    (lambda (str rest)
                      (loop rest (cdr args)
                            (append (reverse (string->list str)) out))))))))
          (else (loop (cdr cs) args (cons (car cs) out))))))

The two strange do loops collect the width and prec modifiers; they encode the standard Scheme expression for while loops. The printf and fprintf functions call sprintf:

(define (printf fmt . args) (display (apply sprintf fmt args)))
(define (fprintf port fmt . args) (display (apply sprintf fmt args) port))

Here are some examples:

> (printf "%c%%hello\\n" 97)
> (printf "|%s|%10s|%-10s|%.3s|%10.3s|%-10.3s|\\n" "January" "January" "January" "January" "January" "January")
|January|   January|January   |Jan|       Jan|Jan       |
> (printf "|%d|%5d|%-5d|%o|%06o|\\\\x%x\\n" 97 97 97 97 97 97)
|97|   97|97   |141|000141|\x61
> (printf "|%f|%.2f|%9.2f|%-9.2f|%09.2f|\\n" 123.4567 123.4567 123.4567 123.4567 123.4567)
|123.4567|123.46|   123.46|123.46   |000123.46|

You can run the program at

Pages: 1 2

3 Responses to “Formatted Output”

  1. Michael D said

    The problem seems to call for `,prec` (note the comma), but your code and examples on the next page appear to expect `.prec` (period-delimited), which is what I believe `sprintf` expects as well.

  2. programmingpraxis said

    Fixed. Thank you.

  3. Jussi Piitulainen said

    ;;; Argument specs in a format string are {dec}, {bin} for decimal and
    ;;; binary formatting of an exact integer, {new} for a newline, and {}
    ;;; for just display. They can start with a position: {0|dec} refers
    ;;; to the same argument as the first {bin} and does not advance the
    ;;; argument counter. -- Just a skeleton.

    (define (format spec args out)
      (define n (string-length spec))
      (let outer ((k 0) (b 0) (e 0))
         ((= e n)
          (display (substring spec b e) out))
         ((char=? (string-ref spec e) #\{)
          (display (substring spec b e) out)
          (let inner ((b (+ e 1)) (e (+ e 1)))
             ((char=? (string-ref spec e) #\})
              (outer (format-case (substring spec b e) args k out) (+ e 1) (+ e 1)))
             (else (inner b (+ e 1))))))
         (else (outer k b (+ e 1))))))

    (define (format-case spec args k out)
      (define n (string-length spec))
          (lambda ()
            (let scan ((k 0))
               ((= k n) (values #f spec))
               ((char=? (string-ref spec k) #\|)
                (values (substring spec 0 k) (substring spec (+ k 1) n)))
               (else (scan (+ k 1))))))
        (lambda (pos spec)
          (define (arg) (list-ref args (if pos (string->number pos) k)))
          (define (next) (if pos k (+ k 1)))
           ((string=? spec "dec")
            (display (number->string (arg) 10) out) (next))
           ((string=? spec "bin")
            (display (number->string (arg) 2) out) (next))
           ((string=? spec "new") (newline out) k)
           ((string=? spec "") (display (arg) out) (next))
           (else (error "Unknown format spec" spec))))))

    ;;; > (format "Binary {bin}{new}= Decimal {0|dec}{new}< Decimal {}{new}"
    ;;; '(2 3) (current-output-port))
    ;;; Binary 10
    ;;; = Decimal 2
    ;;; < Decimal 3

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: