;; Requires some non-R5RS utilities:
;;   - (CALL-WITH-OUTPUT-STRING <consumer>) -> string
;;         (CONSUMER <output-port>)
;;   - (ERROR <message> <irritant> ...)
;;       Used in one place to signal a 'too many arguments' error.
;;   - (ASCII-LIMIT) -> exact, nonnegative integer
;;       The maximum number of ASCII characters.
;;   - (CHAR->ASCII <char>) -> exact, nonnegative integer
;;       The ASCII numeric value for CHAR.
;;       (CHAR->INTEGER doesn't mandate ASCII.)

(define (format formatter write-char)
   (formatter write-char))

(define (format/string formatter)
   (call-with-output-string
     (lambda (out)
       (format formatter (lambda (c) (write-char c out))))))
(define (format/port formatter . maybe-out)
   (format formatter
     (cond ((null? maybe-out)
            write-char)
           ((null? (cdr maybe-out))
            (let ((out (car maybe-out)))
              (lambda (c) (write-char c out))))
           (else
            (error "Too many arguments"
                   (cons format/port (cons formatter maybe-out)))))))
(define (format/char-list formatter)
   (let ((l '()))
     (format formatter (lambda (c) (set! l (cons c l))))
     (reverse l)))

(define (sequence-formatter . formatters)
   (lambda (write-char)
     (for-each (lambda (f) (format f write-char)) formatters)))

(define (string-formatter string)
   (let ((len (string-length string)))
     (lambda (write-char)
       (do ((i 0 (+ i 1))) ((= i len))
         (write-char (string-ref string i))))))
(define (string-literal-formatter string)
   (let ((f (string-formatter string)))
     (lambda (write-char)
       (write-char #\")
       (format f write-char)
       (write-char #\"))))

(define (symbol-formatter symbol)
   (string-formatter (symbol->string symbol)))

;; This is just a simple example using NUMBER->STRING; there should, of
course,
;; be real numeric formatting routines with a lot more power than just
over the
;; radix.
(define (number-formatter number radix)
   (string-formatter (number->string number radix)))

(define (boolean-formatter boolean)
   (string-formatter (if boolean "#t" "#f")))

(define (char-formatter char)
   (lambda (write-char)
     (write-char char)))
(define (char-literal-formatter char)
   (let ((f (cond ((char-name char)
                   => (lambda (x)
                        ((if (string? x) string-formatter
symbol-formatter)
                         x)))
                  (else
                   (char-formatter char)))))
     (lambda (write-char)
       (write-char #\#)
       (write-char #\\)
       (format f write-char))))
;; Make the named characters print more nicely.
(define *char-names* (make-vector (ascii-limit) #f))
(define (char-name char)
   (vector-ref  *char-names* (char->ascii char)))
(define (define-char-name char name)
   (vector-set! *char-names* (char->ascii char) name))
(define-char-name #\space 'space)
(define-char-name #\newline 'newline)
;; Does R5RS define any other named characters?

;; Handles proper & dotted lists, but not circular lists.
(define (list-formatter l x->formatter)
   (cond ((null? l)
          ;; Empty proper list case
          (string-formatter "()"))
         ((not (pair? l))
          ;; Empty dotted list case
          (x->formatter l))
         (else
          ;; Nonempty either list kind case
          (apply sequence-formatter (build-formatter-list l
x->formatter)))))

(define (build-formatter-list l x->formatter)
   (cons (char-formatter #\()
         (cons (x->formatter (car l))
               (let recur ((l (cdr l)))
                 (cond ((null? l)
                        (list (char-formatter #\))))
                       ((not (pair? l))
                        (list (string-formatter " . ")
                              (x->formatter l)
                              (char-formatter #\))))
                       (else
                        (cons (char-formatter #\space)
                              (cons (x->formatter (car l))
                                    (recur (cdr l))))))))))

(define (vector-formatter vec x->formatter)
   ;; This is a cheat.  A real implementation would use a
straightforward vector
   ;; element formatter.
   (sequence-formatter (char-formatter #\#)
                       (list-formatter (vector->list vec) x->formatter)))

;; These two could be a bit more efficient if the formatting library
were to be
;; integrated with the implementations of DISPLAY & WRITE, by not
allocating an
;; intermediate string and generating the formatter for that.
(define (write-formatter object)
   (string-formatter (call-with-output-string
                       (lambda (out) (write object out)))))

(define (display-formatter object)
   (string-formatter (call-with-output-string
                       (lambda (out) (display object out)))))