http://t3x.org/s9fes/format.scm.html

format   Common Lisp-style text formatter

Location: contrib, 786 Lines

; Common LISP-style text output formatter for R4RS Scheme
; By Dirk Lutzebaeck, 1992, 1993
; With some additional hacking by Nils M Holm in 2009.
; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
; Placed in the Public Domain by the authors.
;
; (format #t string-f object ...)           ==>  string | #t | #f
; (format #f string-f object ...)           ==>  string | #t | #f
; (format string string-f object ...)       ==>  string | #t | #f
; (format output-port string-f object ...)  ==>  string | #t | #f
;
; FORMAT Returns #T, #F or a string. It has the side effect of printing
; according to the formatting instruction in STRING. If the first
; argument is #T, the output is to the current output port and #T is
; returned. If the argument is #F, a formatted string is returned as
; the result of the call. If the first argument is is a string, the
; output is appended to that string by string-append (note: this
; returns a fresh string). Otherwise the first argument must be an
; output port and #T is returned.
;
; Characters are output as if they were output by the DISPLAY function
; with the exception of those prefixed by a tilde (~). In case of a
; formatting error FORMAT prints a message on the current output port
; and aborts.  For a detailed description of the STRING-F syntax
; please consult a Common LISP FORMAT reference manual. For a quick
; overview of implemented, not supported and extended control properties
; of STRING-F see "format.txt". For a test suite to verify this FORMAT
; implementation load "format-test.scm".
;
; Example:   (format #f "~A ~:* ~S" '(#\c "s"))
;              ==>  "(c s)  (#\\c \"s\")"
;
;            (format #f "~20,'_,',,3:D" 123456789)
;              ==>  "_________123,456,789"
;
;            (format #f "~@{ ~A,~A ~}" 'a 1 'b 2 'c 3)
;              ==>  " a,1  b,2  c,3 "

(define (format . args)

  (define (abort)
    (error "FORMAT: aborting"))   ; S9fES-specific

  (define destination #f)
  (define output-buffer "")
  (define case-conversion #f)

  (define form-feed (integer->char 12))

  (define tab (integer->char 9))

  ; char->string converts a character into a slashified string as
  ; done by WRITE. The following procedure is dependent on the integer
  ; representation of characters and assumes a character number according
  ; to the ASCII character set.

  (define (char->string ch)
    (let ((int-rep (char->integer ch))
          (ascii-non-printable-charnames
            '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
               "bs"  "ht"  "lf"  "vt"  "np"  "cr"  "so"  "si"
               "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
               "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us"
               "space")))
      (string-append "#\\"
        (cond ((char=? ch #\newline) "newline")
                ((<= 0 int-rep 32)
                  (vector-ref ascii-non-printable-charnames int-rep))
                ((= int-rep 127)
                  "del")
                ((>= int-rep 128)
                  (number->string int-rep 8))
                (else
                  (string ch))))))

  (define (obj->str-padded pad-left obj options params)
    (let ((mincol 0)
          (colinc 1)         ; sorry, I don't understand this CL parm
          (minpad 0)
          (padchar #\space)
          (objstr (apply obj->string (append (list obj) options))))
      (if (null? params)
          objstr
          (begin
            (set! params (append params '(#f #f #f #f)))
            (if (list-ref params 0) (set! mincol (list-ref params 0)))
            (if (list-ref params 1) (set! colinc (list-ref params 1)))
            (if (list-ref params 2) (set! minpad (list-ref params 2)))
            (if (list-ref params 3)
                (set! padchar (integer->char (list-ref params 3))))
            (pad-str objstr (negative? mincol) pad-left
                            (abs mincol) minpad padchar)))))

  (define (num->str-padded modifier number params radix-num radix-prefix)
    (if (not (number? number)) (format-error "argument not a number"))
    (let ((mincol 0)
          (padchar #\space)
          (commachar #\,)
          (commawidth 3)                  ; an extension to CL
          (numstr-len 0)
          (numstr (number->string number radix-num)))

      (if (and (null? params) (not modifier))
          numstr
          (begin
            (set! params (append params '(#f #f #f #f)))
            (if (list-ref params 0) (set! mincol (list-ref params 0)))
            (if (list-ref params 1)
                (set! padchar (integer->char (list-ref params 1))))
            (if (list-ref params 2)
                (set! commachar (integer->char (list-ref params 2))))
            (if (list-ref params 3) (set! commawidth (list-ref params 3)))
            (set! numstr-len (string-length numstr))

            (if (and (memq modifier '(colon colon-at)) ; insert comma char
                     (integer? number))   ; only integers are ,-separated
                (set! numstr
                      (do ((s "")
                           (i (- numstr-len commawidth) (- i commawidth)))
                          ((or (zero? i) (negative? i))
                            (string-append
                              (substring numstr 0 (+ i commawidth )) s))
                        (set! s (string-append
                                  (string commachar)
                                  (substring numstr i (+ i commawidth)) s)))))

            (if (memq modifier '(at colon-at))    ; append numerical prefix
                (set! numstr (string-append radix-prefix numstr)))

            (pad-str numstr (negative? mincol) #t
                            (abs mincol) 0 padchar)))))

  (define (pad-str objstr fixed-field pad-left mincol minpad padchar)
    (let ((objstr-len (string-length objstr)))
      (if fixed-field
          (if (> objstr-len mincol)
              (if pad-left
                  (string-append "<"
                    (substring objstr (- objstr-len (- mincol 1)) objstr-len))
                  (string-append (substring objstr 0 (- mincol 1)) ">"))
              (if pad-left
                  (string-append (make-string (- mincol objstr-len) padchar)
                                 objstr)
                  (string-append objstr
                                 (make-string (- mincol objstr-len) padchar))))
          (if (> objstr-len mincol)
              (if pad-left
                  (string-append (make-string minpad padchar) objstr)
                  (string-append objstr (make-string minpad padchar)))
              (if pad-left
                  (string-append (make-string (- mincol objstr-len) padchar)
                                 objstr)
                  (string-append objstr
                                 (make-string (- mincol objstr-len)
                                              padchar)))))))

  ; obj->string converts an arbitrary scheme object to a string.
  ; `options' is a list of options which may contain the following symbols:
  ;   slashify:      slashifies output string as (write) does
  ;   readproof:     prints out #<...> objects as quoted strings "#<...>" so
  ;                  that the output can always be processed by (read)

  (define (obj->string obj . options)
    (let to-str ((obj obj)
                 (slashify (if (memq 'slashify options) #t #f))
                 (readproof (if (memq 'readproof options) #t #f)))
      (cond
        ((string? obj)
         (if slashify
             (let ((obj-len (string-length obj)))
               (string-append
                 "\""
                 (let loop ((i 0) (j 0))    ; taken from Marc Feeley's pp.scm
                   (if (= j obj-len)
                       (string-append (substring obj i j) "\"")
                       (let ((c (string-ref obj j)))
                         (if (or (char=? c #\\)
                                 (char=? c #\"))
                             (string-append (substring obj i j) "\\"
                                            (loop j (+ j 1)))
                             (loop i (+ j 1))))))))
             obj))
       ((boolean? obj)
         (if obj "#t" "#f"))
       ((number? obj)
         (number->string obj))
       ((symbol? obj)
         (symbol->string obj))
       ((char? obj)
        (if slashify
            (char->string obj)
            (string obj)))
       ((null? obj)
         "()")
       ((procedure? obj)
         (if readproof "\"#<procedure>\"" "#<procedure>"))
       ((output-port? obj)
         (if readproof "\"#<output-port>\"" "#<output-port>"))
       ((input-port? obj)
         (if readproof "\"#<input-port>\"" "#<input-port>"))
       ((pair? obj)            ; from my WRITE-TO-STRING --nmh
         (string-append
           "("
           (let loop ((a obj)
                      (first #t))
             (cond ((pair? a)
                     (string-append (if first "" " ")
                                    (to-str (car a)
                                            slashify
                                            readproof)
                                    (loop (cdr a) #f)))
                   ((null? a)
                     "")
                   (else
                     (string-append
                       " . "
                       (to-str a slashify readproof)))))
           ")"))
       ((eof-object? obj)
         (if readproof "\"#<eof-object>\"" "#<eof-object>"))
       ((vector? obj)
         (string-append "#" (to-str (vector->list obj) 'slashify readproof)))
       (else (if readproof "\"#<unspecified>\"" "#<unspecified>")))))

  (define (string-upcase str)
    (let ((up-str (string-copy str)))
      (do ((i (- (string-length str) 1) (- i 1)))
          ((< i 0) up-str)
        (string-set! up-str i (char-upcase (string-ref str i))))))

  (define (string-downcase str)
    (let ((down-str (string-copy str)))
      (do ((i (- (string-length str) 1) (- i 1)))
          ((< i 0) down-str)
        (string-set! down-str i (char-downcase (string-ref str i))))))

  (define (string-capitalize 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))))
              (set! non-first-alpha #f))))))

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

  (define (out-str str)           ; append to output-buffer
    (set! output-buffer
          (string-append output-buffer
                         (if (procedure? case-conversion)
                             (case-conversion str)
                             str))))

  (define (out-char ch)
    (out-str (string ch)))

  (define (format-error . args*)
    (let ((format-args args))
      (format #t "FORMAT: ")
      (apply format `(#t ,@args*))
      (format #t ", ARGS: ~a~%" format-args)
      (abort)))

  (define parameter-characters
    '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))

  (define (format-work format-string arg-list) ; does the formatting work
    (letrec
      ((format-string-len (string-length format-string))
       (pos 0)                     ; input format-string position
       (arg-pos 0)                 ; argument position in arg-list
       (arg-len (length arg-list))  ; number of arguments
       (modifier #f)               ; 'colon | 'at | 'colon-at | #f
       (params '())                ; directive parameter list
       (param-value-found #f)      ; a directive parameter value found
       (conditional-nest 0)        ; conditional nesting level
       (clause-pos 0)              ; last cond. clause beginning char pos
       (clause-default #f)         ; conditional default clause string
       (clauses '())               ; conditional clause string list
       (conditional-type #f)       ; reflects the contional modifiers
       (conditional-arg #f)        ; argument to apply the conditional
       (iteration-nest 0)          ; iteration nesting level
       (iteration-pos 0)           ; iteration string beginning char pos
       (iteration-type #f)         ; reflects the iteration modifiers
       (max-iterations #f)         ; maximum number of iterations
       (cond-indicators (append '(#\[ #\] #\; #\: #\@ #\^)
                                parameter-characters))
       (iter-indicators (append '(#\{ #\} #\: #\@ #\^)
                                parameter-characters))

       (next-char
         (lambda ()
           (let ((ch (peek-next-char)))
             (set! pos (+ 1 pos))
             ch)))

       (peek-next-char
         (lambda ()
           (if (>= pos format-string-len)
               (format-error "illegal format string")
               (string-ref format-string pos))))

       (one-positive-integer?
         (lambda (params)
           (cond ((null? params)
                   #f)
                 ((and (integer? (car params))
                       (>= (car params) 0)
                       (null? (cdr params)))
                   #t)
                 (else (fail "one positive integer parameter expected")))))

       (add-arg-pos
         (lambda (n)
           (set! arg-pos (+ n arg-pos))))

       (next-arg
         (lambda ()
           (if (>= arg-pos arg-len)
               (format-error "missing argument(s)"))
           (add-arg-pos 1)
           (list-ref arg-list (- arg-pos 1))))

       (prev-arg
         (lambda ()
           (add-arg-pos -1)
           (if (negative? arg-pos)
               (format-error "missing backward argument(s)"))
           (list-ref arg-list arg-pos)))

       (rest-args
         (lambda ()
           (list-tail arg-list arg-pos)))

       (fail
         (lambda (fmt . args)
           (apply format-error
                  `(,(string-append fmt ", POS: \"~a\"")
                    ,@args
                    ,(string-append
                      (substring format-string 0 pos)
                      "<--"
                      (substring format-string pos format-string-len))))))

       (char-dispatch
         (lambda ()
           (if (>= pos format-string-len)
               arg-pos                       ; used for ~? continuance
               (let ((char (next-char)))
                 (cond ((char=? char #\~)
                         (set! modifier #f)
                         (set! params '())
                         (set! param-value-found #f)
                         (tilde-dispatch))
                       (else
                         (if (and (zero? conditional-nest)
                                  (zero? iteration-nest))
                             (out-char char))
                         (char-dispatch)))))))

       (tilde-dispatch
         (lambda ()
           (cond
             ((>= pos format-string-len)
               (out-str "~")        ; tilde at end of string is just output
               arg-pos)             ; used for ~? continuance
             ((and (or (zero? conditional-nest)
                       (memv (peek-next-char) cond-indicators))
                   (or (zero? iteration-nest)
                       (memv (peek-next-char) iter-indicators)))
               (case (char-upcase (next-char))

                 ; format directives

                 ((#\A)                    ; Any -- for humans
                   (out-str
                     (obj->str-padded (memq modifier '(at colon-at))
                                      (next-arg)
                                      (if (eq? modifier 'colon)
                                          '(readproof)
                                          '())
                                      params))
                    (char-dispatch))
                 ((#\S)                    ; Slashified -- for parsers
                   (out-str
                     (obj->str-padded (memq modifier '(at colon-at))
                                      (next-arg)
                                      (if (eq? modifier 'colon)
                                          '(readproof slashify)
                                          '(slashify))
                                      params))
                   (char-dispatch))
                 ((#\D)                    ; Decimal
                   (out-str
                     (num->str-padded modifier (next-arg) params 10 "#d"))
                   (char-dispatch))
                 ((#\X)                    ; Hexadecimal
                   (out-str
                    (num->str-padded modifier (next-arg) params 16 "#x"))
                   (char-dispatch))
                 ((#\O)                    ; Octal
                   (out-str
                    (num->str-padded modifier (next-arg) params 8 "#o"))
                   (char-dispatch))
                 ((#\B)                    ; Binary
                   (out-str
                    (num->str-padded modifier (next-arg) params 2 "#b"))
                   (char-dispatch))
                 ((#\R)                    ; any Radix
                   (if (null? params)
                       (fail "~~r requires an explicit radix")
                       (out-str (num->str-padded modifier
                                                 (next-arg)
                                                 (cdr params)
                                                 (car params)
                                                 "#r")))
                   (char-dispatch))
                 ((#\E #\F #\G #\$)        ; Floating point
                   (fail "~~e, ~~f, ~~g, ~~$ are not implemented"))
                 ((#\C)                    ; Character
                   (let ((ch (if (one-positive-integer? params)
                                 (integer->char (car params))
                                 (next-arg))))
                     (if (not (char? ch)) (fail "~~c expects a character"))
                     (if (eq? modifier 'at)
                         (out-str (obj->string ch 'slashify))
                         (out-char ch)))
                   (char-dispatch))
                 ((#\P)                    ; Plural
                   (if (memq modifier '(colon colon-at))
                       (prev-arg))
                   (let ((arg (next-arg)))
                     (if (not (number? arg))
                         (fail "~~p expects a number argument"))
                     (if (= arg 1)
                         (if (memq modifier '(at colon-at))
                             (out-str "y"))
                         (if (memq modifier '(at colon-at))
                             (out-str "ies")
                             (out-str "s"))))
                   (char-dispatch))
                 ((#\~)            ; Tilde
                   (if (one-positive-integer? params)
                       (out-str (make-string (car params) #\~))
                       (out-str "~"))
                   (char-dispatch))
                 ((#\% #\&)                ; Newline (Freshline is the same)
                   (if (one-positive-integer? params)
                       (out-str (make-string (car params) #\newline))
                       (out-char #\newline))
                   (char-dispatch))
                 ((#\_)                    ; Space
                   (if (one-positive-integer? params)
                       (out-str (make-string (car params) #\space))
                       (out-str " "))
                   (char-dispatch))
                 ((#\T)                    ; Tab
                   (if (one-positive-integer? params)
                       (out-str (make-string (car params) tab))
                       (out-char tab))
                   (char-dispatch))
                 ((#\|)                    ; Page Seperator
                   (if (one-positive-integer? params)
                       (out-str (make-string (car params) form-feed))
                       (out-char form-feed))
                   (char-dispatch))
                 ((#\? #\K)                ; Indirection (is "~K" in T)
                   (cond
                     ((memq modifier '(colon colon-at))
                       (fail "illegal modifier in ~~?"))
                     ((eq? modifier 'at)
                       (let* ((frmt (next-arg))
                              (args (rest-args)))
                         (add-arg-pos (format-work frmt args))))
                     (else
                       (let* ((frmt (next-arg))
                              (args (next-arg)))
                         (format-work frmt args))))
                   (char-dispatch))
                 ((#\newline)              ; Continuation lines
                   (if (eq? modifier 'at)
                       (out-char #\newline))
                   (if (< pos format-string-len)
                       (do ((ch (peek-next-char) (peek-next-char)))
                           ((or (not (char-whitespace? ch))
                                (= pos (- format-string-len 1))))
                         (if (eq? modifier 'colon)
                             (out-char (next-char))
                             (next-char))))
                   (char-dispatch))
                 ((#\*)                    ; Argument jumping
                   (case modifier
                     ((colon)              ; jump backwards
                       (if (one-positive-integer? params)
                           (do ((i 0 (+ i 1)))
                               ((= i (car params)))
                             (prev-arg))
                           (prev-arg)))
                     ((at)                 ; jump absolute
                       (set! arg-pos (if (one-positive-integer? params)
                                         (car params) 0)))
                     ((colon-at)
                       (fail "illegal modifier `:@' in ~~* directive"))
                     (else                 ; jump forward
                       (if (one-positive-integer? params)
                           (do ((i 0 (+ i 1)))
                               ((= i (car params)))
                             (next-arg))
                           (next-arg))))
                   (char-dispatch))
                 ((#\()                    ; Case conversion begin
                   (set! case-conversion
                         (case modifier
                           ((at) string-capitalize-first)
                           ((colon) string-capitalize)
                           ((colon-at) string-upcase)
                           (else string-downcase)))
                   (char-dispatch))
                 ((#\))                    ; Case conversion end
                   (if (not case-conversion)
                       (fail "missing ~~(")) ; )balance
                   (set! case-conversion #f)
                   (char-dispatch))
                 ((#\[)                    ; Conditional begin
                   (set! conditional-nest (+ conditional-nest 1))
                   (cond
                     ((= conditional-nest 1)
                       (set! clause-pos pos)
                       (set! clause-default #f)
                       (set! clauses '())
                       (set! conditional-type
                             (case modifier
                               ((at) 'if-then)
                               ((colon) 'if-else-then)
                               ((colon-at) (fail "illegal modifier in ~~["))
                               (else 'num-case)))
                       (set! conditional-arg
                             (if (one-positive-integer? params)
                                 (car params)
                                 (next-arg)))))
                   (char-dispatch))
                 ((#\;)                    ; Conditional separator
                   (if (zero? conditional-nest)
                       (fail "~~; not in ~~[~~] conditional"))
                   (if (not (null? params))
                       (fail "no parameter allowed in ~~;"))
                   (if (= conditional-nest 1)
                       (let ((clause-str
                              (cond
                                ((eq? modifier 'colon)
                                  (set! clause-default #t)
                                  (substring format-string
                                             clause-pos
                                             (- pos 3)))
                                ((memq modifier '(at colon-at))
                                  (fail "illegal modifier in ~~;"))
                                (else
                                  (substring format-string
                                             clause-pos
                                             (- pos 2))))))
                         (set! clauses (append clauses (list clause-str)))
                         (set! clause-pos pos)))
                   (char-dispatch))
                 ((#\])                    ; Conditional end
                   (if (zero? conditional-nest) (fail "missing ~~["))
                   (set! conditional-nest (- conditional-nest 1))
                   (if modifier
                       (fail "no modifier allowed in ~~]"))
                   (if (not (null? params))
                       (fail "no parameter allowed in ~~]"))
                   (cond
                     ((zero? conditional-nest)
                       (let ((clause-str (substring format-string
                                                    clause-pos
                                                    (- pos 2))))
                         (if clause-default
                             (set! clause-default clause-str)
                             (set! clauses
                                   (append clauses (list clause-str)))))
                       (case conditional-type
                         ((if-then)
                           (if conditional-arg
                               (format-work (car clauses)
                                            (list conditional-arg))))
                         ((if-else-then)
                           (add-arg-pos
                             (format-work (if conditional-arg
                                              (cadr clauses)
                                              (car clauses))
                                          (rest-args))))
                         ((num-case)
                           (if (or (not (integer? conditional-arg))
                                   (< conditional-arg 0))
                               (fail "argument not a positive integer"))
                           (if (not (and (>= conditional-arg (length clauses))
                                         (not clause-default)))
                               (add-arg-pos
                                 (format-work
                                   (if (>= conditional-arg (length clauses))
                                       clause-default
                                       (list-ref clauses conditional-arg))
                                   (rest-args))))))))
                   (char-dispatch))
                 ((#\{)                    ; Iteration begin
                   (set! iteration-nest (+ iteration-nest 1))
                   (cond
                     ((= iteration-nest 1)
                       (set! iteration-pos pos)
                       (set! iteration-type
                             (case modifier
                               ((at) 'rest-args)
                               ((colon) 'sublists)
                               ((colon-at) 'rest-sublists)
                               (else 'list)))
                       (set! max-iterations (if (one-positive-integer? params)
                                                (car params)
                                                #f))))
                   (char-dispatch))
                 ((#\})                    ; Iteration end
                   (if (zero? iteration-nest) (fail "missing ~~{"))
                   (set! iteration-nest (- iteration-nest 1))
                   (case modifier
                     ((colon)
                       (if (not max-iterations) (set! max-iterations 1)))
                     ((colon-at at)
                       (fail "illegal modifier"))
                     (else
                       (if (not max-iterations)
                           (set! max-iterations 100))))
                   (if (not (null? params))
                       (fail "no parameters allowed in ~~}"))
                   (if (zero? iteration-nest)
                     (let ((iteration-str
                            (substring format-string
                                       iteration-pos
                                       (- pos (if modifier 3 2)))))
                       (if (string=? iteration-str "")
                           (set! iteration-str (next-arg)))
                       (case iteration-type
                         ((list)
                           (let ((args (next-arg))
                                 (args-len 0))
                             (if (not (list? args))
                                 (fail "expected a list argument"))
                             (set! args-len (length args))
                             (do ((arg-pos 0 (+ arg-pos
                                                (format-work
                                                  iteration-str
                                                  (list-tail args arg-pos))))
                                  (i 0 (+ i 1)))
                                 ((or (>= arg-pos args-len)
                                      (>= i max-iterations))))))
                         ((sublists)
                           (let ((args (next-arg))
                                 (args-len 0))
                             (if (not (list? args))
                                 (fail "expected a list argument"))
                             (set! args-len (length args))
                             (do ((arg-pos 0 (+ arg-pos 1)))
                                 ((or (>= arg-pos args-len)
                                      (>= arg-pos max-iterations)))
                               (let ((sublist (list-ref args arg-pos)))
                                 (if (not (list? sublist))
                                     (fail
                                       "expected a list of lists argument"))
                                 (format-work iteration-str sublist)))))
                         ((rest-args)
                           (let* ((args (rest-args))
                                  (args-len (length args))
                                  (usedup-args
                                    (do ((arg-pos 0 (+ arg-pos
                                                       (format-work
                                                         iteration-str
                                                         (list-tail args
                                                                    arg-pos))))
                                         (i 0 (+ i 1)))
                                        ((or (>= arg-pos args-len)
                                             (>= i max-iterations))
                                         arg-pos))))
                             (add-arg-pos usedup-args)))
                         ((rest-sublists)
                           (let* ((args (rest-args))
                                  (args-len (length args))
                                  (usedup-args
                                    (do ((arg-pos 0 (+ arg-pos 1)))
                                        ((or (>= arg-pos args-len)
                                             (>= arg-pos max-iterations))
                                         arg-pos)
                                      (let ((sublist (list-ref args arg-pos)))
                                        (if (not (list? sublist))
                                            (fail "expected list arguments"))
                                        (format-work iteration-str sublist)))))
                             (add-arg-pos usedup-args)))
                         (else (fail "internal error in ~~}")))))
                   (char-dispatch))
                 ((#\^)                    ; Up and out
                   (let*
                     ((continue
                       (cond
                         ((not (null? params))
                           (not
                             (case (length params)
                               ((1) (zero? (car params)))
                               ((2) (= (list-ref params 0)
                                       (list-ref params 1)))
                               ((3) (<= (list-ref params 0)
                                        (list-ref params 1)
                                        (list-ref params 2)))
                               (else (fail "too many parameters")))))
                         (case-conversion ; if in conversion, stop conversion
                           (set! case-conversion string-copy) #t)
                         ((= iteration-nest 1) #t)
                         ((= conditional-nest 1) #t)
                         ((>= arg-pos arg-len)
                           (set! pos format-string-len) #f)
                         (else #t))))
                     (if continue
                         (char-dispatch))))

                 ; format directive modifiers and parameters

                 ((#\@)                    ; `@' modifier
                   (if (eq? modifier 'colon-at)
                       (fail "double `@' modifier"))
                   (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
                   (tilde-dispatch))
                 ((#\:)                    ; `:' modifier
                   (if modifier (fail "illegal `:' modifier position"))
                   (set! modifier 'colon)
                   (tilde-dispatch))
                 ((#\')                    ; Character parameter
                   (if modifier (fail "misplaced modifier"))
                   (set! params (append params
                                        (list (char->integer (next-char)))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                 ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+)
                   (if modifier (fail "misplaced modifier"))
                   (let ((num-str-beg (- pos 1))
                         (num-str-end pos))
                     (do ((ch (peek-next-char) (peek-next-char)))
                         ((not (char-numeric? ch)))
                       (next-char)
                       (set! num-str-end (+ 1 num-str-end)))
                     (set! params
                           (append params
                                   (list (string->number
                                          (substring format-string
                                                     num-str-beg
                                                     num-str-end))))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                 ((#\V)                    ; Variable parameter from next argum.
                   (if modifier (fail "misplaced modifier"))
                   (set! params (append params (list (next-arg))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                 ((#\#)                    ; Number of remaining args
                   (if modifier (fail "misplaced modifier"))
                   (set! params (append params (list (length (rest-args)))))
                   (set! param-value-found #t)
                   (tilde-dispatch))
                 ((#\,)                    ; Parameter separators
                   (if modifier (fail "misplaced modifier"))
                   (if (not param-value-found)
                       (set! params (append params '(#f)))) ; append empty pmtr
                   (set! param-value-found #f)
                   (tilde-dispatch))
                 (else                     ; Unknown tilde directive
                   (fail "unknown control character `~c'"
                         (string-ref format-string (- pos 1))))))
             (else (char-dispatch)))))) ; in case of conditional

    (char-dispatch)                  ; start formatting
    arg-pos))                        ; return position in arg. list

  (if (< (length args) 2)
      (format-error "not enough arguments"))
  (let ((destination (car args))
        (format-string (cadr args))
        (arg-list (cddr args)))
    (set! destination
          (cond
            ((boolean? destination)
              (if destination (current-output-port) #f))
            ((output-port? destination) destination)
            ((string? destination) destination)
            (else (format-error "illegal destination `~a'" output-port))))
    (if (not (string? format-string))
        (format-error "illegal format string `~a'" format-string))
    (set! output-buffer "")
    (set! case-conversion #f) ; modifier case conversion procedure
    (let ((arg-pos (format-work format-string arg-list))
          (arg-len (length arg-list)))
      (cond
        ((< arg-pos arg-len)
          (format-error "~a superfluous argument~:p" (- arg-len arg-pos)))
        ((> arg-pos arg-len)
          (format-error "~a missing argument~:p" (- arg-pos arg-len)))
        ((output-port? destination)
          (display output-buffer destination)
          #t)
        ((string? destination)
          (string-append destination output-buffer))
        (else output-buffer)))))

contact  |  privacy