guile18/ice-9/format.scm

   1 ;;;; "format.scm" Common LISP text output formatter for SLIB
   2 ;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
   3 ;;; Assimilated into Guile May 1999
   4 ;;
   5 ;; This code is in the public domain.
   6
   7 ;; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
   8 ;; Please send error reports to bug-guile@gnu.org.
   9 ;; For documentation see slib.texi and format.doc.
  10 ;; For testing load formatst.scm.
  11 ;;
  12 ;; Version 3.0
  13
  14 (define-module (ice-9 format)
  15   :use-module (ice-9 and-let-star)
  16   :autoload (ice-9 pretty-print) (pretty-print)
  17   :replace (format)
  18   :export (format:symbol-case-conv
  19            format:iobj-case-conv
  20            format:expch))
  21
  22 ;;; Configuration ------------------------------------------------------------
  23
  24 (define format:symbol-case-conv #f)
  25 ;; Symbols are converted by symbol->string so the case of the printed
  26 ;; symbols is implementation dependent. format:symbol-case-conv is a
  27 ;; one arg closure which is either #f (no conversion), string-upcase!,
  28 ;; string-downcase! or string-capitalize!.
  29
  30 (define format:iobj-case-conv #f)
  31 ;; As format:symbol-case-conv but applies for the representation of
  32 ;; implementation internal objects.
  33
  34 (define format:expch #\E)
  35 ;; The character prefixing the exponent value in ~e printing.
  36
  37 (define format:floats (provided? 'inexact))
  38 ;; Detects if the scheme system implements flonums (see at eof).
  39
  40 (define format:complex-numbers (provided? 'complex))
  41 ;; Detects if the scheme system implements complex numbers.
  42
  43 (define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
  44 ;; Detects if number->string adds a radix prefix.
  45
  46 (define format:ascii-non-printable-charnames
  47   '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
  48      "bs"  "ht"  "nl"  "vt"  "np"  "cr"  "so"  "si"
  49      "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
  50      "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us" "space"))
  51
  52 ;;; End of configuration ----------------------------------------------------
  53
  54 (define (format . args)
  55   (letrec
  56       ((format:version "3.0")
  57        (format:port #f)                 ; curr. format output port
  58        (format:output-col 0)            ; curr. format output tty column
  59        (format:flush-output #f)         ; flush output at end of formatting
  60        (format:case-conversion #f)
  61        (format:args #f)
  62        (format:pos 0)                   ; curr. format string parsing position
  63        (format:arg-pos 0)               ; curr. format argument position
  64                                         ; this is global for error presentation
  65
  66        ;; format string and char output routines on format:port
  67
  68        (format:out-str
  69         (lambda (str)
  70           (if format:case-conversion
  71               (display (format:case-conversion str) format:port)
  72               (display str format:port))
  73           (set! format:output-col
  74                 (+ format:output-col (string-length str)))))
  75
  76        (format:out-char
  77         (lambda (ch)
  78           (if format:case-conversion
  79               (display (format:case-conversion (string ch))
  80                        format:port)
  81               (write-char ch format:port))
  82           (set! format:output-col
  83                 (if (char=? ch #\newline)
  84                     0
  85                     (+ format:output-col 1)))))
  86
  87        ;;(define (format:out-substr str i n)  ; this allocates a new string
  88        ;;  (display (substring str i n) format:port)
  89        ;;  (set! format:output-col (+ format:output-col n)))
  90
  91        (format:out-substr
  92         (lambda (str i n)
  93           (do ((k i (+ k 1)))
  94               ((= k n))
  95             (write-char (string-ref str k) format:port))
  96           (set! format:output-col (+ format:output-col (- n i)))))
  97
  98        ;;(define (format:out-fill n ch)       ; this allocates a new string
  99        ;;  (format:out-str (make-string n ch)))
 100
 101        (format:out-fill
 102         (lambda (n ch)
 103           (do ((i 0 (+ i 1)))
 104               ((= i n))
 105             (write-char ch format:port))
 106           (set! format:output-col (+ format:output-col n))))
 107
 108        ;; format's user error handler
 109
 110        (format:error
 111         (lambda args            ; never returns!
 112           (let ((format-args format:args)
 113                 (port (current-error-port)))
 114             (set! format:error format:intern-error)
 115             (if (and (>= (length format:args) 2)
 116                      (string? (cadr format:args)))
 117                 (let ((format-string (cadr format-args)))
 118                   (if (not (zero? format:arg-pos))
 119                       (set! format:arg-pos (- format:arg-pos 1)))
 120                   (format port
 121                           "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
 122                                   ~{~a ~}===>~{~a ~})~%        "
 123                           (car format:args)
 124                           (substring format-string 0 format:pos)
 125                           (substring format-string format:pos
 126                                      (string-length format-string))
 127                           (list-head (cddr format:args) format:arg-pos)
 128                           (list-tail (cddr format:args) format:arg-pos)))
 129                 (format port
 130                         "~%FORMAT: error with call: (format~{ ~a~})~%        "
 131                         format:args))
 132             (apply format port args)
 133             (newline port)
 134             (set! format:error format:error-save)
 135             (format:abort))))
 136
 137        (format:intern-error
 138         (lambda args
 139           ;;if something goes wrong in format:error
 140           (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
 141           (display "        format args: ") (write format:args) (newline)
 142           (display "        error args:  ") (write args) (newline)
 143           (set! format:error format:error-save)
 144           (format:abort)))
 145
 146        (format:error-save #f)
 147
 148        (format:format
 149         (lambda args            ; the formatter entry
 150           (set! format:args args)
 151           (set! format:arg-pos 0)
 152           (set! format:pos 0)
 153           (if (< (length args) 1)
 154               (format:error "not enough arguments"))
 155
 156           ;; If the first argument is a string, then that's the format string.
 157           ;; (Scheme->C)
 158           ;; In this case, put the argument list in canonical form.
 159           (let ((args (if (string? (car args))
 160                           (cons #f args)
 161                           args)))
 162             ;; Use this canonicalized version when reporting errors.
 163             (set! format:args args)
 164
 165             (let ((destination (car args))
 166                   (arglist (cdr args)))
 167               (cond
 168                ((or (and (boolean? destination) ; port output
 169                          destination)
 170                     (output-port? destination)
 171                     (number? destination))
 172                 (format:out (cond
 173                              ((boolean? destination) (current-output-port))
 174                              ((output-port? destination) destination)
 175                              ((number? destination) (current-error-port)))
 176                             (car arglist) (cdr arglist)))
 177                ((and (boolean? destination)     ; string output
 178                      (not destination))
 179                 (call-with-output-string
 180                  (lambda (port) (format:out port (car arglist) (cdr arglist)))))
 181                (else
 182                 (format:error "illegal destination `~a'" destination)))))))
 183
 184        (format:out                              ; the output handler for a port
 185         (lambda (port fmt args)
 186           (set! format:port port)               ; global port for
 187                                         ; output routines
 188           (set! format:case-conversion #f)      ; modifier case
 189                                         ; conversion procedure
 190           (set! format:flush-output #f)         ; ~! reset
 191           (and-let* ((col (port-column port)))  ; get current column from port
 192                     (set! format:output-col col))
 193           (let ((arg-pos (format:format-work fmt args))
 194                 (arg-len (length args)))
 195             (cond
 196              ((> arg-pos arg-len)
 197               (set! format:arg-pos (+ arg-len 1))
 198               (display format:arg-pos)
 199               (format:error "~a missing argument~:p" (- arg-pos arg-len)))
 200              (else
 201               (if format:flush-output (force-output port))
 202               #t)))))
 203
 204        (format:parameter-characters
 205         '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
 206
 207        (format:format-work ; does the formatting work
 208         (lambda (format-string arglist)
 209           (letrec
 210               ((format-string-len (string-length format-string))
 211                (arg-pos 0)                      ; argument position in arglist
 212                (arg-len (length arglist))       ; number of arguments
 213                (modifier #f)                    ; 'colon | 'at | 'colon-at | #f
 214                (params '())                     ; directive parameter list
 215                (param-value-found #f)           ; a directive
 216                                         ; parameter value
 217                                         ; found
 218                (conditional-nest 0)             ; conditional nesting level
 219                (clause-pos 0)                   ; last cond. clause
 220                                         ; beginning char pos
 221                (clause-default #f)              ; conditional default
 222                                         ; clause string
 223                (clauses '())                    ; conditional clause
 224                                         ; string list
 225                (conditional-type #f)            ; reflects the
 226                                         ; contional modifiers
 227                (conditional-arg #f)             ; argument to apply the conditional
 228                (iteration-nest 0)               ; iteration nesting level
 229                (iteration-pos 0)                ; iteration string
 230                                         ; beginning char pos
 231                (iteration-type #f)              ; reflects the
 232                                         ; iteration modifiers
 233                (max-iterations #f)              ; maximum number of
 234                                         ; iterations
 235                (recursive-pos-save format:pos)
 236
 237                (next-char                       ; gets the next char
 238                                         ; from format-string
 239                 (lambda ()
 240                   (let ((ch (peek-next-char)))
 241                     (set! format:pos (+ 1 format:pos))
 242                     ch)))
 243
 244                (peek-next-char
 245                 (lambda ()
 246                   (if (>= format:pos format-string-len)
 247                       (format:error "illegal format string")
 248                       (string-ref format-string format:pos))))
 249
 250                (one-positive-integer?
 251                 (lambda (params)
 252                   (cond
 253                    ((null? params) #f)
 254                    ((and (integer? (car params))
 255                          (>= (car params) 0)
 256                          (= (length params) 1)) #t)
 257                    (else
 258                     (format:error
 259                      "one positive integer parameter expected")))))
 260
 261                (next-arg
 262                 (lambda ()
 263                   (if (>= arg-pos arg-len)
 264                       (begin
 265                         (set! format:arg-pos (+ arg-len 1))
 266                         (format:error "missing argument(s)")))
 267                   (add-arg-pos 1)
 268                   (list-ref arglist (- arg-pos 1))))
 269
 270                (prev-arg
 271                 (lambda ()
 272                   (add-arg-pos -1)
 273                   (if (negative? arg-pos)
 274                       (format:error "missing backward argument(s)"))
 275                   (list-ref arglist arg-pos)))
 276
 277                (rest-args
 278                 (lambda ()
 279                   (let loop ((l arglist) (k arg-pos)) ; list-tail definition
 280                     (if (= k 0) l (loop (cdr l) (- k 1))))))
 281
 282                (add-arg-pos
 283                 (lambda (n)
 284                   (set! arg-pos (+ n arg-pos))
 285                   (set! format:arg-pos arg-pos)))
 286
 287                (anychar-dispatch                ; dispatches the format-string
 288                 (lambda ()
 289                   (if (>= format:pos format-string-len)
 290                       arg-pos                   ; used for ~? continuance
 291                       (let ((char (next-char)))
 292                         (cond
 293                          ((char=? char #\~)
 294                           (set! modifier #f)
 295                           (set! params '())
 296                           (set! param-value-found #f)
 297                           (tilde-dispatch))
 298                          (else
 299                           (if (and (zero? conditional-nest)
 300                                    (zero? iteration-nest))
 301                               (format:out-char char))
 302                           (anychar-dispatch)))))))
 303
 304                (tilde-dispatch
 305                 (lambda ()
 306                   (cond
 307                    ((>= format:pos format-string-len)
 308                     (format:out-str "~")        ; tilde at end of
 309                                         ; string is just
 310                                         ; output
 311                     arg-pos)                    ; used for ~?
 312                                         ; continuance
 313                    ((and (or (zero? conditional-nest)
 314                              (memv (peek-next-char) ; find conditional
 315                                         ; directives
 316                                    (append '(#\[ #\] #\; #\: #\@ #\^)
 317                                            format:parameter-characters)))
 318                          (or (zero? iteration-nest)
 319                              (memv (peek-next-char) ; find iteration
 320                                         ; directives
 321                                    (append '(#\{ #\} #\: #\@ #\^)
 322                                            format:parameter-characters))))
 323                     (case (char-upcase (next-char))
 324
 325                       ;; format directives
 326
 327                       ((#\A)                    ; Any -- for humans
 328                        (set! format:read-proof
 329                              (memq modifier '(colon colon-at)))
 330                        (format:out-obj-padded (memq modifier '(at colon-at))
 331                                               (next-arg) #f params)
 332                        (anychar-dispatch))
 333                       ((#\S)                    ; Slashified -- for parsers
 334                        (set! format:read-proof
 335                              (memq modifier '(colon colon-at)))
 336                        (format:out-obj-padded (memq modifier '(at colon-at))
 337                                               (next-arg) #t params)
 338                        (anychar-dispatch))
 339                       ((#\D)                    ; Decimal
 340                        (format:out-num-padded modifier (next-arg) params 10)
 341                        (anychar-dispatch))
 342                       ((#\X)                    ; Hexadecimal
 343                        (format:out-num-padded modifier (next-arg) params 16)
 344                        (anychar-dispatch))
 345                       ((#\O)                    ; Octal
 346                        (format:out-num-padded modifier (next-arg) params 8)
 347                        (anychar-dispatch))
 348                       ((#\B)                    ; Binary
 349                        (format:out-num-padded modifier (next-arg) params 2)
 350                        (anychar-dispatch))
 351                       ((#\R)
 352                        (if (null? params)
 353                            (format:out-obj-padded ; Roman, cardinal,
 354                                         ; ordinal numerals
 355                             #f
 356                             ((case modifier
 357                                ((at) format:num->roman)
 358                                ((colon-at) format:num->old-roman)
 359                                ((colon) format:num->ordinal)
 360                                (else format:num->cardinal))
 361                              (next-arg))
 362                             #f params)
 363                            (format:out-num-padded ; any Radix
 364                             modifier (next-arg) (cdr params) (car params)))
 365                        (anychar-dispatch))
 366                       ((#\F)                    ; Fixed-format floating-point
 367                        (if format:floats
 368                            (format:out-fixed modifier (next-arg) params)
 369                            (format:out-str (number->string (next-arg))))
 370                        (anychar-dispatch))
 371                       ((#\E)                    ; Exponential floating-point
 372                        (if format:floats
 373                            (format:out-expon modifier (next-arg) params)
 374                            (format:out-str (number->string (next-arg))))
 375                        (anychar-dispatch))
 376                       ((#\G)                    ; General floating-point
 377                        (if format:floats
 378                            (format:out-general modifier (next-arg) params)
 379                            (format:out-str (number->string (next-arg))))
 380                        (anychar-dispatch))
 381                       ((#\$)                    ; Dollars floating-point
 382                        (if format:floats
 383                            (format:out-dollar modifier (next-arg) params)
 384                            (format:out-str (number->string (next-arg))))
 385                        (anychar-dispatch))
 386                       ((#\I)                    ; Complex numbers
 387                        (if (not format:complex-numbers)
 388                            (format:error
 389                             "complex numbers not supported by this scheme system"))
 390                        (let ((z (next-arg)))
 391                          (if (not (complex? z))
 392                              (format:error "argument not a complex number"))
 393                          (format:out-fixed modifier (real-part z) params)
 394                          (format:out-fixed 'at (imag-part z) params)
 395                          (format:out-char #\i))
 396                        (anychar-dispatch))
 397                       ((#\C)                    ; Character
 398                        (let ((ch (if (one-positive-integer? params)
 399                                      (integer->char (car params))
 400                                      (next-arg))))
 401                          (if (not (char? ch))
 402                              (format:error "~~c expects a character"))
 403                          (case modifier
 404                            ((at)
 405                             (format:out-str (format:char->str ch)))
 406                            ((colon)
 407                             (let ((c (char->integer ch)))
 408                               (if (< c 0)
 409                                   (set! c (+ c 256))) ; compensate
 410                                         ; complement
 411                                         ; impl.
 412                               (cond
 413                                ((< c #x20)      ; assumes that control
 414                                         ; chars are < #x20
 415                                 (format:out-char #\^)
 416                                 (format:out-char
 417                                  (integer->char (+ c #x40))))
 418                                ((>= c #x7f)
 419                                 (format:out-str "#\\")
 420                                 (format:out-str
 421                                  (if format:radix-pref
 422                                      (let ((s (number->string c 8)))
 423                                        (substring s 2 (string-length s)))
 424                                      (number->string c 8))))
 425                                (else
 426                                 (format:out-char ch)))))
 427                            (else (format:out-char ch))))
 428                        (anychar-dispatch))
 429                       ((#\P)                    ; Plural
 430                        (if (memq modifier '(colon colon-at))
 431                            (prev-arg))
 432                        (let ((arg (next-arg)))
 433                          (if (not (number? arg))
 434                              (format:error "~~p expects a number argument"))
 435                          (if (= arg 1)
 436                              (if (memq modifier '(at colon-at))
 437                                  (format:out-char #\y))
 438                              (if (memq modifier '(at colon-at))
 439                                  (format:out-str "ies")
 440                                  (format:out-char #\s))))
 441                        (anychar-dispatch))
 442                       ((#\~)                    ; Tilde
 443                        (if (one-positive-integer? params)
 444                            (format:out-fill (car params) #\~)
 445                            (format:out-char #\~))
 446                        (anychar-dispatch))
 447                       ((#\%)                    ; Newline
 448                        (if (one-positive-integer? params)
 449                            (format:out-fill (car params) #\newline)
 450                            (format:out-char #\newline))
 451                        (set! format:output-col 0)
 452                        (anychar-dispatch))
 453                       ((#\&)                    ; Fresh line
 454                        (if (one-positive-integer? params)
 455                            (begin
 456                              (if (> (car params) 0)
 457                                  (format:out-fill (- (car params)
 458                                                      (if (>
 459                                                           format:output-col
 460                                                           0) 0 1))
 461                                                   #\newline))
 462                              (set! format:output-col 0))
 463                            (if (> format:output-col 0)
 464                                (format:out-char #\newline)))
 465                        (anychar-dispatch))
 466                       ((#\_)                    ; Space character
 467                        (if (one-positive-integer? params)
 468                            (format:out-fill (car params) #\space)
 469                            (format:out-char #\space))
 470                        (anychar-dispatch))
 471                       ((#\/)                    ; Tabulator character
 472                        (if (one-positive-integer? params)
 473                            (format:out-fill (car params) #\tab)
 474                            (format:out-char #\tab))
 475                        (anychar-dispatch))
 476                       ((#\|)                    ; Page seperator
 477                        (if (one-positive-integer? params)
 478                            (format:out-fill (car params) #\page)
 479                            (format:out-char #\page))
 480                        (set! format:output-col 0)
 481                        (anychar-dispatch))
 482                       ((#\T)                    ; Tabulate
 483                        (format:tabulate modifier params)
 484                        (anychar-dispatch))
 485                       ((#\Y)                    ; Pretty-print
 486                        (pretty-print (next-arg) format:port)
 487                        (set! format:output-col 0)
 488                        (anychar-dispatch))
 489                       ((#\? #\K)                ; Indirection (is "~K" in T-Scheme)
 490                        (cond
 491                         ((memq modifier '(colon colon-at))
 492                          (format:error "illegal modifier in ~~?"))
 493                         ((eq? modifier 'at)
 494                          (let* ((frmt (next-arg))
 495                                 (args (rest-args)))
 496                            (add-arg-pos (format:format-work frmt args))))
 497                         (else
 498                          (let* ((frmt (next-arg))
 499                                 (args (next-arg)))
 500                            (format:format-work frmt args))))
 501                        (anychar-dispatch))
 502                       ((#\!)                    ; Flush output
 503                        (set! format:flush-output #t)
 504                        (anychar-dispatch))
 505                       ((#\newline)              ; Continuation lines
 506                        (if (eq? modifier 'at)
 507                            (format:out-char #\newline))
 508                        (if (< format:pos format-string-len)
 509                            (do ((ch (peek-next-char) (peek-next-char)))
 510                                ((or (not (char-whitespace? ch))
 511                                     (= format:pos (- format-string-len 1))))
 512                              (if (eq? modifier 'colon)
 513                                  (format:out-char (next-char))
 514                                  (next-char))))
 515                        (anychar-dispatch))
 516                       ((#\*)                    ; Argument jumping
 517                        (case modifier
 518                          ((colon)               ; jump backwards
 519                           (if (one-positive-integer? params)
 520                               (do ((i 0 (+ i 1)))
 521                                   ((= i (car params)))
 522                                 (prev-arg))
 523                               (prev-arg)))
 524                          ((at)                  ; jump absolute
 525                           (set! arg-pos (if (one-positive-integer? params)
 526                                             (car params) 0)))
 527                          ((colon-at)
 528                           (format:error "illegal modifier `:@' in ~~* directive"))
 529                          (else                  ; jump forward
 530                           (if (one-positive-integer? params)
 531                               (do ((i 0 (+ i 1)))
 532                                   ((= i (car params)))
 533                                 (next-arg))
 534                               (next-arg))))
 535                        (anychar-dispatch))
 536                       ((#\()                    ; Case conversion begin
 537                        (set! format:case-conversion
 538                              (case modifier
 539                                ((at) string-capitalize-first)
 540                                ((colon) string-capitalize)
 541                                ((colon-at) string-upcase)
 542                                (else string-downcase)))
 543                        (anychar-dispatch))
 544                       ((#\))                    ; Case conversion end
 545                        (if (not format:case-conversion)
 546                            (format:error "missing ~~("))
 547                        (set! format:case-conversion #f)
 548                        (anychar-dispatch))
 549                       ((#\[)                    ; Conditional begin
 550                        (set! conditional-nest (+ conditional-nest 1))
 551                        (cond
 552                         ((= conditional-nest 1)
 553                          (set! clause-pos format:pos)
 554                          (set! clause-default #f)
 555                          (set! clauses '())
 556                          (set! conditional-type
 557                                (case modifier
 558                                  ((at) 'if-then)
 559                                  ((colon) 'if-else-then)
 560                                  ((colon-at) (format:error "illegal modifier in ~~["))
 561                                  (else 'num-case)))
 562                          (set! conditional-arg
 563                                (if (one-positive-integer? params)
 564                                    (car params)
 565                                    (next-arg)))))
 566                        (anychar-dispatch))
 567                       ((#\;)                    ; Conditional separator
 568                        (if (zero? conditional-nest)
 569                            (format:error "~~; not in ~~[~~] conditional"))
 570                        (if (not (null? params))
 571                            (format:error "no parameter allowed in ~~;"))
 572                        (if (= conditional-nest 1)
 573                            (let ((clause-str
 574                                   (cond
 575                                    ((eq? modifier 'colon)
 576                                     (set! clause-default #t)
 577                                     (substring format-string clause-pos
 578                                                (- format:pos 3)))
 579                                    ((memq modifier '(at colon-at))
 580                                     (format:error "illegal modifier in ~~;"))
 581                                    (else
 582                                     (substring format-string clause-pos
 583                                                (- format:pos 2))))))
 584                              (set! clauses (append clauses (list clause-str)))
 585                              (set! clause-pos format:pos)))
 586                        (anychar-dispatch))
 587                       ((#\])                    ; Conditional end
 588                        (if (zero? conditional-nest) (format:error "missing ~~["))
 589                        (set! conditional-nest (- conditional-nest 1))
 590                        (if modifier
 591                            (format:error "no modifier allowed in ~~]"))
 592                        (if (not (null? params))
 593                            (format:error "no parameter allowed in ~~]"))
 594                        (cond
 595                         ((zero? conditional-nest)
 596                          (let ((clause-str (substring format-string clause-pos
 597                                                       (- format:pos 2))))
 598                            (if clause-default
 599                                (set! clause-default clause-str)
 600                                (set! clauses (append clauses (list clause-str)))))
 601                          (case conditional-type
 602                            ((if-then)
 603                             (if conditional-arg
 604                                 (format:format-work (car clauses)
 605                                                     (list conditional-arg))))
 606                            ((if-else-then)
 607                             (add-arg-pos
 608                              (format:format-work (if conditional-arg
 609                                                      (cadr clauses)
 610                                                      (car clauses))
 611                                                  (rest-args))))
 612                            ((num-case)
 613                             (if (or (not (integer? conditional-arg))
 614                                     (< conditional-arg 0))
 615                                 (format:error "argument not a positive integer"))
 616                             (if (not (and (>= conditional-arg (length clauses))
 617                                           (not clause-default)))
 618                                 (add-arg-pos
 619                                  (format:format-work
 620                                   (if (>= conditional-arg (length clauses))
 621                                       clause-default
 622                                       (list-ref clauses conditional-arg))
 623                                   (rest-args))))))))
 624                        (anychar-dispatch))
 625                       ((#\{)                    ; Iteration begin
 626                        (set! iteration-nest (+ iteration-nest 1))
 627                        (cond
 628                         ((= iteration-nest 1)
 629                          (set! iteration-pos format:pos)
 630                          (set! iteration-type
 631                                (case modifier
 632                                  ((at) 'rest-args)
 633                                  ((colon) 'sublists)
 634                                  ((colon-at) 'rest-sublists)
 635                                  (else 'list)))
 636                          (set! max-iterations (if (one-positive-integer? params)
 637                                                   (car params) #f))))
 638                        (anychar-dispatch))
 639                       ((#\})                    ; Iteration end
 640                        (if (zero? iteration-nest) (format:error "missing ~~{"))
 641                        (set! iteration-nest (- iteration-nest 1))
 642                        (case modifier
 643                          ((colon)
 644                           (if (not max-iterations) (set! max-iterations 1)))
 645                          ((colon-at at) (format:error "illegal modifier")))
 646                        (if (not (null? params))
 647                            (format:error "no parameters allowed in ~~}"))
 648                        (if (zero? iteration-nest)
 649                            (let ((iteration-str
 650                                   (substring format-string iteration-pos
 651                                              (- format:pos (if modifier 3 2)))))
 652                              (if (string=? iteration-str "")
 653                                  (set! iteration-str (next-arg)))
 654                              (case iteration-type
 655                                ((list)
 656                                 (let ((args (next-arg))
 657                                       (args-len 0))
 658                                   (if (not (list? args))
 659                                       (format:error "expected a list argument"))
 660                                   (set! args-len (length args))
 661                                   (do ((arg-pos 0 (+ arg-pos
 662                                                      (format:format-work
 663                                                       iteration-str
 664                                                       (list-tail args arg-pos))))
 665                                        (i 0 (+ i 1)))
 666                                       ((or (>= arg-pos args-len)
 667                                            (and max-iterations
 668                                                 (>= i max-iterations)))))))
 669                                ((sublists)
 670                                 (let ((args (next-arg))
 671                                       (args-len 0))
 672                                   (if (not (list? args))
 673                                       (format:error "expected a list argument"))
 674                                   (set! args-len (length args))
 675                                   (do ((arg-pos 0 (+ arg-pos 1)))
 676                                       ((or (>= arg-pos args-len)
 677                                            (and max-iterations
 678                                                 (>= arg-pos max-iterations))))
 679                                     (let ((sublist (list-ref args arg-pos)))
 680                                       (if (not (list? sublist))
 681                                           (format:error
 682                                            "expected a list of lists argument"))
 683                                       (format:format-work iteration-str sublist)))))
 684                                ((rest-args)
 685                                 (let* ((args (rest-args))
 686                                        (args-len (length args))
 687                                        (usedup-args
 688                                         (do ((arg-pos 0 (+ arg-pos
 689                                                            (format:format-work
 690                                                             iteration-str
 691                                                             (list-tail
 692                                                              args arg-pos))))
 693                                              (i 0 (+ i 1)))
 694                                             ((or (>= arg-pos args-len)
 695                                                  (and max-iterations
 696                                                       (>= i max-iterations)))
 697                                              arg-pos))))
 698                                   (add-arg-pos usedup-args)))
 699                                ((rest-sublists)
 700                                 (let* ((args (rest-args))
 701                                        (args-len (length args))
 702                                        (usedup-args
 703                                         (do ((arg-pos 0 (+ arg-pos 1)))
 704                                             ((or (>= arg-pos args-len)
 705                                                  (and max-iterations
 706                                                       (>= arg-pos max-iterations)))
 707                                              arg-pos)
 708                                           (let ((sublist (list-ref args arg-pos)))
 709                                             (if (not (list? sublist))
 710                                                 (format:error "expected list arguments"))
 711                                             (format:format-work iteration-str sublist)))))
 712                                   (add-arg-pos usedup-args)))
 713                                (else (format:error "internal error in ~~}")))))
 714                        (anychar-dispatch))
 715                       ((#\^)                    ; Up and out
 716                        (let* ((continue
 717                                (cond
 718                                 ((not (null? params))
 719                                  (not
 720                                   (case (length params)
 721                                     ((1) (zero? (car params)))
 722                                     ((2) (= (list-ref params 0) (list-ref params 1)))
 723                                     ((3) (<= (list-ref params 0)
 724                                              (list-ref params 1)
 725                                              (list-ref params 2)))
 726                                     (else (format:error "too much parameters")))))
 727                                 (format:case-conversion ; if conversion stop conversion
 728                                  (set! format:case-conversion string-copy) #t)
 729                                 ((= iteration-nest 1) #t)
 730                                 ((= conditional-nest 1) #t)
 731                                 ((>= arg-pos arg-len)
 732                                  (set! format:pos format-string-len) #f)
 733                                 (else #t))))
 734                          (if continue
 735                              (anychar-dispatch))))
 736
 737                       ;; format directive modifiers and parameters
 738
 739                       ((#\@)                    ; `@' modifier
 740                        (if (memq modifier '(at colon-at))
 741                            (format:error "double `@' modifier"))
 742                        (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
 743                        (tilde-dispatch))
 744                       ((#\:)                    ; `:' modifier
 745                        (if (memq modifier '(colon colon-at))
 746                            (format:error "double `:' modifier"))
 747                        (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
 748                        (tilde-dispatch))
 749                       ((#\')                    ; Character parameter
 750                        (if modifier (format:error "misplaced modifier"))
 751                        (set! params (append params (list (char->integer (next-char)))))
 752                        (set! param-value-found #t)
 753                        (tilde-dispatch))
 754                       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
 755                        (if modifier (format:error "misplaced modifier"))
 756                        (let ((num-str-beg (- format:pos 1))
 757                              (num-str-end format:pos))
 758                          (do ((ch (peek-next-char) (peek-next-char)))
 759                              ((not (char-numeric? ch)))
 760                            (next-char)
 761                            (set! num-str-end (+ 1 num-str-end)))
 762                          (set! params
 763                                (append params
 764                                        (list (string->number
 765                                               (substring format-string
 766                                                          num-str-beg
 767                                                          num-str-end))))))
 768                        (set! param-value-found #t)
 769                        (tilde-dispatch))
 770                       ((#\V)                    ; Variable parameter from next argum.
 771                        (if modifier (format:error "misplaced modifier"))
 772                        (set! params (append params (list (next-arg))))
 773                        (set! param-value-found #t)
 774                        (tilde-dispatch))
 775                       ((#\#)                    ; Parameter is number of remaining args
 776                        (if param-value-found (format:error "misplaced '#'"))
 777                        (if modifier (format:error "misplaced modifier"))
 778                        (set! params (append params (list (length (rest-args)))))
 779                        (set! param-value-found #t)
 780                        (tilde-dispatch))
 781                       ((#\,)                    ; Parameter separators
 782                        (if modifier (format:error "misplaced modifier"))
 783                        (if (not param-value-found)
 784                            (set! params (append params '(#f)))) ; append empty paramtr
 785                        (set! param-value-found #f)
 786                        (tilde-dispatch))
 787                       ((#\Q)                    ; Inquiry messages
 788                        (if (eq? modifier 'colon)
 789                            (format:out-str format:version)
 790                            (let ((nl (string #\newline)))
 791                              (format:out-str
 792                               (string-append
 793                                "SLIB Common LISP format version " format:version nl
 794                                "  (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
 795                                "  please send bug reports to `lutzeb@cs.tu-berlin.de'"
 796                                nl))))
 797                        (anychar-dispatch))
 798                       (else                     ; Unknown tilde directive
 799                        (format:error "unknown control character `~c'"
 800                                      (string-ref format-string (- format:pos 1))))))
 801                    (else (anychar-dispatch)))))) ; in case of conditional
 802
 803             (set! format:pos 0)
 804             (set! format:arg-pos 0)
 805             (anychar-dispatch)                  ; start the formatting
 806             (set! format:pos recursive-pos-save)
 807             arg-pos)))                          ; return the position in the arg. list
 808
 809        ;; when format:read-proof is true, format:obj->str will wrap
 810        ;; result strings starting with "#<" in an extra pair of double
 811        ;; quotes.
 812
 813        (format:read-proof #f)
 814
 815        ;; format:obj->str returns a R4RS representation as a string of
 816        ;; an arbitrary scheme object.
 817
 818        (format:obj->str
 819         (lambda (obj slashify)
 820           (let ((res (if slashify
 821                          (object->string obj)
 822                          (with-output-to-string (lambda () (display obj))))))
 823             (if (and format:read-proof (string-prefix? "#<" res))
 824                 (object->string res)
 825                 res))))
 826
 827        ;; format:char->str converts a character into a slashified string as
 828        ;; done by `write'. The procedure is dependent on the integer
 829        ;; representation of characters and assumes a character number according to
 830        ;; the ASCII character set.
 831
 832        (format:char->str
 833         (lambda (ch)
 834           (let ((int-rep (char->integer ch)))
 835             (if (< int-rep 0)                   ; if chars are [-128...+127]
 836                 (set! int-rep (+ int-rep 256)))
 837             (string-append
 838              "#\\"
 839              (cond
 840               ((char=? ch #\newline) "newline")
 841               ((and (>= int-rep 0) (<= int-rep 32))
 842                (vector-ref format:ascii-non-printable-charnames int-rep))
 843               ((= int-rep 127) "del")
 844               ((>= int-rep 128)         ; octal representation
 845                (if format:radix-pref
 846                    (let ((s (number->string int-rep 8)))
 847                      (substring s 2 (string-length s)))
 848                    (number->string int-rep 8)))
 849               (else (string ch)))))))
 850
 851        (format:space-ch (char->integer #\space))
 852        (format:zero-ch (char->integer #\0))
 853
 854        (format:par
 855         (lambda (pars length index default name)
 856           (if (> length index)
 857               (let ((par (list-ref pars index)))
 858                 (if par
 859                     (if name
 860                         (if (< par 0)
 861                             (format:error
 862                              "~s parameter must be a positive integer" name)
 863                             par)
 864                         par)
 865                     default))
 866               default)))
 867
 868        (format:out-obj-padded
 869         (lambda (pad-left obj slashify pars)
 870                (if (null? pars)
 871                    (format:out-str (format:obj->str obj slashify))
 872                    (let ((l (length pars)))
 873                      (let ((mincol (format:par pars l 0 0 "mincol"))
 874                            (colinc (format:par pars l 1 1 "colinc"))
 875                            (minpad (format:par pars l 2 0 "minpad"))
 876                            (padchar (integer->char
 877                                      (format:par pars l 3 format:space-ch #f)))
 878                            (objstr (format:obj->str obj slashify)))
 879                        (if (not pad-left)
 880                            (format:out-str objstr))
 881                        (do ((objstr-len (string-length objstr))
 882                             (i minpad (+ i colinc)))
 883                            ((>= (+ objstr-len i) mincol)
 884                             (format:out-fill i padchar)))
 885                        (if pad-left
 886                            (format:out-str objstr)))))))
 887
 888        (format:out-num-padded
 889         (lambda (modifier number pars radix)
 890           (if (not (integer? number)) (format:error "argument not an integer"))
 891           (let ((numstr (number->string number radix)))
 892             (if (and format:radix-pref (not (= radix 10)))
 893                 (set! numstr (substring numstr 2 (string-length numstr))))
 894             (if (and (null? pars) (not modifier))
 895                 (format:out-str numstr)
 896                 (let ((l (length pars))
 897                       (numstr-len (string-length numstr)))
 898                   (let ((mincol (format:par pars l 0 #f "mincol"))
 899                         (padchar (integer->char
 900                                   (format:par pars l 1 format:space-ch #f)))
 901                         (commachar (integer->char
 902                                     (format:par pars l 2 (char->integer #\,) #f)))
 903                         (commawidth (format:par pars l 3 3 "commawidth")))
 904                     (if mincol
 905                         (let ((numlen numstr-len)) ; calc. the output len of number
 906                           (if (and (memq modifier '(at colon-at)) (>= number 0))
 907                               (set! numlen (+ numlen 1)))
 908                           (if (memq modifier '(colon colon-at))
 909                               (set! numlen (+ (quotient (- numstr-len
 910                                                            (if (< number 0) 2 1))
 911                                                         commawidth)
 912                                               numlen)))
 913                           (if (> mincol numlen)
 914                               (format:out-fill (- mincol numlen) padchar))))
 915                     (if (and (memq modifier '(at colon-at))
 916                              (>= number 0))
 917                         (format:out-char #\+))
 918                     (if (memq modifier '(colon colon-at)) ; insert comma character
 919                         (let ((start (remainder numstr-len commawidth))
 920                               (ns (if (< number 0) 1 0)))
 921                           (format:out-substr numstr 0 start)
 922                           (do ((i start (+ i commawidth)))
 923                               ((>= i numstr-len))
 924                             (if (> i ns)
 925                                 (format:out-char commachar))
 926                             (format:out-substr numstr i (+ i commawidth))))
 927                         (format:out-str numstr))))))))
 928
 929        (format:tabulate
 930         (lambda (modifier pars)
 931           (let ((l (length pars)))
 932             (let ((colnum (format:par pars l 0 1 "colnum"))
 933                   (colinc (format:par pars l 1 1 "colinc"))
 934                   (padch (integer->char (format:par pars l 2 format:space-ch #f))))
 935               (case modifier
 936                 ((colon colon-at)
 937                  (format:error "unsupported modifier for ~~t"))
 938                 ((at)                           ; relative tabulation
 939                  (format:out-fill
 940                   (if (= colinc 0)
 941                       colnum                    ; colnum = colrel
 942                       (do ((c 0 (+ c colinc))
 943                            (col (+ format:output-col colnum)))
 944                           ((>= c col)
 945                            (- c format:output-col))))
 946                   padch))
 947                 (else                           ; absolute tabulation
 948                  (format:out-fill
 949                   (cond
 950                    ((< format:output-col colnum)
 951                     (- colnum format:output-col))
 952                    ((= colinc 0)
 953                     0)
 954                    (else
 955                     (do ((c colnum (+ c colinc)))
 956                         ((>= c format:output-col)
 957                          (- c format:output-col)))))
 958                   padch)))))))
 959
 960
 961        ;; roman numerals (from dorai@cs.rice.edu).
 962
 963        (format:roman-alist
 964         '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
 965           (10 #\X) (5 #\V) (1 #\I)))
 966
 967        (format:roman-boundary-values
 968         '(100 100 10 10 1 1 #f))
 969
 970        (format:num->old-roman
 971         (lambda (n)
 972           (if (and (integer? n) (>= n 1))
 973               (let loop ((n n)
 974                          (romans format:roman-alist)
 975                          (s '()))
 976                 (if (null? romans) (list->string (reverse s))
 977                     (let ((roman-val (caar romans))
 978                           (roman-dgt (cadar romans)))
 979                       (do ((q (quotient n roman-val) (- q 1))
 980                            (s s (cons roman-dgt s)))
 981                           ((= q 0)
 982                            (loop (remainder n roman-val)
 983                                  (cdr romans) s))))))
 984               (format:error "only positive integers can be romanized"))))
 985
 986        (format:num->roman
 987         (lambda (n)
 988           (if (and (integer? n) (> n 0))
 989               (let loop ((n n)
 990                          (romans format:roman-alist)
 991                          (boundaries format:roman-boundary-values)
 992                          (s '()))
 993                 (if (null? romans)
 994                     (list->string (reverse s))
 995                     (let ((roman-val (caar romans))
 996                           (roman-dgt (cadar romans))
 997                           (bdry (car boundaries)))
 998                       (let loop2 ((q (quotient n roman-val))
 999                                   (r (remainder n roman-val))
1000                                   (s s))
1001                         (if (= q 0)
1002                             (if (and bdry (>= r (- roman-val bdry)))
1003                                 (loop (remainder r bdry) (cdr romans)
1004                                       (cdr boundaries)
1005                                       (cons roman-dgt
1006                                             (append
1007                                              (cdr (assv bdry romans))
1008                                              s)))
1009                                 (loop r (cdr romans) (cdr boundaries) s))
1010                             (loop2 (- q 1) r (cons roman-dgt s)))))))
1011               (format:error "only positive integers can be romanized"))))
1012
1013        ;; cardinals & ordinals (from dorai@cs.rice.edu)
1014
1015        (format:cardinal-ones-list
1016         '(#f "one" "two" "three" "four" "five"
1017              "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
1018              "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
1019              "nineteen"))
1020
1021        (format:cardinal-tens-list
1022         '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
1023              "ninety"))
1024
1025        (format:num->cardinal999
1026         (lambda (n)
1027                                         ;this procedure is inspired by the Bruno Haible's CLisp
1028                                         ;function format-small-cardinal, which converts numbers
1029                                         ;in the range 1 to 999, and is used for converting each
1030                                         ;thousand-block in a larger number
1031           (let* ((hundreds (quotient n 100))
1032                  (tens+ones (remainder n 100))
1033                  (tens (quotient tens+ones 10))
1034                  (ones (remainder tens+ones 10)))
1035             (append
1036              (if (> hundreds 0)
1037                  (append
1038                   (string->list
1039                    (list-ref format:cardinal-ones-list hundreds))
1040                   (string->list" hundred")
1041                   (if (> tens+ones 0) '(#\space) '()))
1042                  '())
1043              (if (< tens+ones 20)
1044                  (if (> tens+ones 0)
1045                      (string->list
1046                       (list-ref format:cardinal-ones-list tens+ones))
1047                      '())
1048                  (append
1049                   (string->list
1050                    (list-ref format:cardinal-tens-list tens))
1051                   (if (> ones 0)
1052                       (cons #\-
1053                             (string->list
1054                              (list-ref format:cardinal-ones-list ones)))
1055                       '())))))))
1056
1057        (format:cardinal-thousand-block-list
1058         '("" " thousand" " million" " billion" " trillion" " quadrillion"
1059           " quintillion" " sextillion" " septillion" " octillion" " nonillion"
1060           " decillion" " undecillion" " duodecillion" " tredecillion"
1061           " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
1062           " octodecillion" " novemdecillion" " vigintillion"))
1063
1064        (format:num->cardinal
1065         (lambda (n)
1066           (cond ((not (integer? n))
1067                  (format:error
1068                   "only integers can be converted to English cardinals"))
1069                 ((= n 0) "zero")
1070                 ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
1071                 (else
1072                  (let ((power3-word-limit
1073                         (length format:cardinal-thousand-block-list)))
1074                    (let loop ((n n)
1075                               (power3 0)
1076                               (s '()))
1077                      (if (= n 0)
1078                          (list->string s)
1079                          (let ((n-before-block (quotient n 1000))
1080                                (n-after-block (remainder n 1000)))
1081                            (loop n-before-block
1082                                  (+ power3 1)
1083                                  (if (> n-after-block 0)
1084                                      (append
1085                                       (if (> n-before-block 0)
1086                                           (string->list ", ") '())
1087                                       (format:num->cardinal999 n-after-block)
1088                                       (if (< power3 power3-word-limit)
1089                                           (string->list
1090                                            (list-ref
1091                                             format:cardinal-thousand-block-list
1092                                             power3))
1093                                           (append
1094                                            (string->list " times ten to the ")
1095                                            (string->list
1096                                             (format:num->ordinal
1097                                              (* power3 3)))
1098                                            (string->list " power")))
1099                                       s)
1100                                      s))))))))))
1101
1102        (format:ordinal-ones-list
1103         '(#f "first" "second" "third" "fourth" "fifth"
1104              "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
1105              "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
1106              "eighteenth" "nineteenth"))
1107
1108        (format:ordinal-tens-list
1109         '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
1110              "seventieth" "eightieth" "ninetieth"))
1111
1112        (format:num->ordinal
1113         (lambda (n)
1114           (cond ((not (integer? n))
1115                  (format:error
1116                   "only integers can be converted to English ordinals"))
1117                 ((= n 0) "zeroth")
1118                 ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
1119                 (else
1120                  (let ((hundreds (quotient n 100))
1121                        (tens+ones (remainder n 100)))
1122                    (string-append
1123                     (if (> hundreds 0)
1124                         (string-append
1125                          (format:num->cardinal (* hundreds 100))
1126                          (if (= tens+ones 0) "th" " "))
1127                         "")
1128                     (if (= tens+ones 0) ""
1129                         (if (< tens+ones 20)
1130                             (list-ref format:ordinal-ones-list tens+ones)
1131                             (let ((tens (quotient tens+ones 10))
1132                                   (ones (remainder tens+ones 10)))
1133                               (if (= ones 0)
1134                                   (list-ref format:ordinal-tens-list tens)
1135                                   (string-append
1136                                    (list-ref format:cardinal-tens-list tens)
1137                                    "-"
1138                                    (list-ref format:ordinal-ones-list ones))))
1139                             ))))))))
1140
1141        ;; format inf and nan.
1142
1143        (format:out-inf-nan
1144         (lambda (number width digits edigits overch padch)
1145           ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
1146           ;; "+nan.0", suitably justified in their field.  We insist on
1147           ;; printing this exact form so that the numbers can be read back in.
1148
1149           (let* ((str (number->string number))
1150                  (len (string-length str))
1151                  (dot (string-index str #\.))
1152                  (digits (+ (or digits 0)
1153                             (if edigits (+ edigits 2) 0))))
1154             (if (and width overch (< width len))
1155                 (format:out-fill width (integer->char overch))
1156                 (let* ((leftpad (if width
1157                                     (max (- width (max len (+ dot 1 digits))) 0)
1158                                     0))
1159                        (rightpad (if width
1160                                      (max (- width leftpad len) 0)
1161                                      0))
1162                        (padch (integer->char (or padch format:space-ch))))
1163                   (format:out-fill leftpad padch)
1164                   (format:out-str str)
1165                   (format:out-fill rightpad padch))))))
1166
1167        ;; format fixed flonums (~F)
1168
1169        (format:out-fixed
1170         (lambda (modifier number pars)
1171           (if (not (or (number? number) (string? number)))
1172               (format:error "argument is not a number or a number string"))
1173
1174           (let ((l (length pars)))
1175             (let ((width (format:par pars l 0 #f "width"))
1176                   (digits (format:par pars l 1 #f "digits"))
1177                   (scale (format:par pars l 2 0 #f))
1178                   (overch (format:par pars l 3 #f #f))
1179                   (padch (format:par pars l 4 format:space-ch #f)))
1180
1181               (cond
1182                ((or (inf? number) (nan? number))
1183                 (format:out-inf-nan number width digits #f overch padch))
1184
1185                (digits
1186                 (format:parse-float
1187                  (if (string? number) number (number->string number)) #t scale)
1188                 (if (<= (- format:fn-len format:fn-dot) digits)
1189                     (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1190                     (format:fn-round digits))
1191                 (if width
1192                     (let ((numlen (+ format:fn-len 1)))
1193                       (if (or (not format:fn-pos?) (eq? modifier 'at))
1194                           (set! numlen (+ numlen 1)))
1195                       (if (and (= format:fn-dot 0) (> width (+ digits 1)))
1196                           (set! numlen (+ numlen 1)))
1197                       (if (< numlen width)
1198                           (format:out-fill (- width numlen) (integer->char padch)))
1199                       (if (and overch (> numlen width))
1200                           (format:out-fill width (integer->char overch))
1201                           (format:fn-out modifier (> width (+ digits 1)))))
1202                     (format:fn-out modifier #t)))
1203
1204                (else
1205                 (format:parse-float
1206                  (if (string? number) number (number->string number)) #t scale)
1207                 (format:fn-strip)
1208                 (if width
1209                     (let ((numlen (+ format:fn-len 1)))
1210                       (if (or (not format:fn-pos?) (eq? modifier 'at))
1211                           (set! numlen (+ numlen 1)))
1212                       (if (= format:fn-dot 0)
1213                           (set! numlen (+ numlen 1)))
1214                       (if (< numlen width)
1215                           (format:out-fill (- width numlen) (integer->char padch)))
1216                       (if (> numlen width)      ; adjust precision if possible
1217                           (let ((dot-index (- numlen
1218                                               (- format:fn-len format:fn-dot))))
1219                             (if (> dot-index width)
1220                                 (if overch      ; numstr too big for required width
1221                                     (format:out-fill width (integer->char overch))
1222                                     (format:fn-out modifier #t))
1223                                 (begin
1224                                   (format:fn-round (- width dot-index))
1225                                   (format:fn-out modifier #t))))
1226                           (format:fn-out modifier #t)))
1227                     (format:fn-out modifier #t))))))))
1228
1229        ;; format exponential flonums (~E)
1230
1231        (format:out-expon
1232         (lambda (modifier number pars)
1233           (if (not (or (number? number) (string? number)))
1234               (format:error "argument is not a number"))
1235
1236           (let ((l (length pars)))
1237             (let ((width (format:par pars l 0 #f "width"))
1238                   (digits (format:par pars l 1 #f "digits"))
1239                   (edigits (format:par pars l 2 #f "exponent digits"))
1240                   (scale (format:par pars l 3 1 #f))
1241                   (overch (format:par pars l 4 #f #f))
1242                   (padch (format:par pars l 5 format:space-ch #f))
1243                   (expch (format:par pars l 6 #f #f)))
1244
1245               (cond
1246                ((or (inf? number) (nan? number))
1247                 (format:out-inf-nan number width digits edigits overch padch))
1248
1249                (digits                          ; fixed precision
1250
1251                 (let ((digits (if (> scale 0)
1252                                   (if (< scale (+ digits 2))
1253                                       (+ (- digits scale) 1)
1254                                       0)
1255                                   digits)))
1256                   (format:parse-float
1257                    (if (string? number) number (number->string number)) #f scale)
1258                   (if (<= (- format:fn-len format:fn-dot) digits)
1259                       (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1260                       (format:fn-round digits))
1261                   (if width
1262                       (if (and edigits overch (> format:en-len edigits))
1263                           (format:out-fill width (integer->char overch))
1264                           (let ((numlen (+ format:fn-len 3))) ; .E+
1265                             (if (or (not format:fn-pos?) (eq? modifier 'at))
1266                                 (set! numlen (+ numlen 1)))
1267                             (if (and (= format:fn-dot 0) (> width (+ digits 1)))
1268                                 (set! numlen (+ numlen 1)))
1269                             (set! numlen
1270                                   (+ numlen
1271                                      (if (and edigits (>= edigits format:en-len))
1272                                          edigits
1273                                          format:en-len)))
1274                             (if (< numlen width)
1275                                 (format:out-fill (- width numlen)
1276                                                  (integer->char padch)))
1277                             (if (and overch (> numlen width))
1278                                 (format:out-fill width (integer->char overch))
1279                                 (begin
1280                                   (format:fn-out modifier (> width (- numlen 1)))
1281                                   (format:en-out edigits expch)))))
1282                       (begin
1283                         (format:fn-out modifier #t)
1284                         (format:en-out edigits expch)))))
1285
1286                (else
1287                 (format:parse-float
1288                  (if (string? number) number (number->string number)) #f scale)
1289                 (format:fn-strip)
1290                 (if width
1291                     (if (and edigits overch (> format:en-len edigits))
1292                         (format:out-fill width (integer->char overch))
1293                         (let ((numlen (+ format:fn-len 3))) ; .E+
1294                           (if (or (not format:fn-pos?) (eq? modifier 'at))
1295                               (set! numlen (+ numlen 1)))
1296                           (if (= format:fn-dot 0)
1297                               (set! numlen (+ numlen 1)))
1298                           (set! numlen
1299                                 (+ numlen
1300                                    (if (and edigits (>= edigits format:en-len))
1301                                        edigits
1302                                        format:en-len)))
1303                           (if (< numlen width)
1304                               (format:out-fill (- width numlen)
1305                                                (integer->char padch)))
1306                           (if (> numlen width) ; adjust precision if possible
1307                               (let ((f (- format:fn-len format:fn-dot))) ; fract len
1308                                 (if (> (- numlen f) width)
1309                                     (if overch ; numstr too big for required width
1310                                         (format:out-fill width
1311                                                          (integer->char overch))
1312                                         (begin
1313                                           (format:fn-out modifier #t)
1314                                           (format:en-out edigits expch)))
1315                                     (begin
1316                                       (format:fn-round (+ (- f numlen) width))
1317                                       (format:fn-out modifier #t)
1318                                       (format:en-out edigits expch))))
1319                               (begin
1320                                 (format:fn-out modifier #t)
1321                                 (format:en-out edigits expch)))))
1322                     (begin
1323                       (format:fn-out modifier #t)
1324                       (format:en-out edigits expch)))))))))
1325
1326        ;; format general flonums (~G)
1327
1328        (format:out-general
1329         (lambda (modifier number pars)
1330           (if (not (or (number? number) (string? number)))
1331               (format:error "argument is not a number or a number string"))
1332
1333           (let ((l (length pars)))
1334             (let ((width (if (> l 0) (list-ref pars 0) #f))
1335                   (digits (if (> l 1) (list-ref pars 1) #f))
1336                   (edigits (if (> l 2) (list-ref pars 2) #f))
1337                   (overch (if (> l 4) (list-ref pars 4) #f))
1338                   (padch (if (> l 5) (list-ref pars 5) #f)))
1339               (cond
1340                ((or (inf? number) (nan? number))
1341                 ;; FIXME: this isn't right.
1342                 (format:out-inf-nan number width digits edigits overch padch))
1343                (else
1344                 (format:parse-float
1345                  (if (string? number) number (number->string number)) #t 0)
1346                 (format:fn-strip)
1347                 (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
1348                        (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
1349                        (n (if (= format:fn-dot 0)       ; number less than (abs 1.0) ?
1350                               (- (format:fn-zlead))
1351                               format:fn-dot))
1352                        (d (if digits
1353                               digits
1354                               (max format:fn-len (min n 7)))) ; q = format:fn-len
1355                        (dd (- d n)))
1356                   (if (<= 0 dd d)
1357                       (begin
1358                         (format:out-fixed modifier number (list ww dd #f overch padch))
1359                         (format:out-fill ee #\space)) ;~@T not implemented yet
1360                       (format:out-expon modifier number pars)))))))))
1361
1362        ;; format dollar flonums (~$)
1363
1364        (format:out-dollar
1365         (lambda (modifier number pars)
1366           (if (not (or (number? number) (string? number)))
1367               (format:error "argument is not a number or a number string"))
1368
1369           (let ((l (length pars)))
1370             (let ((digits (format:par pars l 0 2 "digits"))
1371                   (mindig (format:par pars l 1 1 "mindig"))
1372                   (width (format:par pars l 2 0 "width"))
1373                   (padch (format:par pars l 3 format:space-ch #f)))
1374
1375               (cond
1376                ((or (inf? number) (nan? number))
1377                 (format:out-inf-nan number width digits #f #f padch))
1378
1379                (else
1380                 (format:parse-float
1381                  (if (string? number) number (number->string number)) #t 0)
1382                 (if (<= (- format:fn-len format:fn-dot) digits)
1383                     (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1384                     (format:fn-round digits))
1385                 (let ((numlen (+ format:fn-len 1)))
1386                   (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
1387                       (set! numlen (+ numlen 1)))
1388                   (if (and mindig (> mindig format:fn-dot))
1389                       (set! numlen (+ numlen (- mindig format:fn-dot))))
1390                   (if (and (= format:fn-dot 0) (not mindig))
1391                       (set! numlen (+ numlen 1)))
1392                   (if (< numlen width)
1393                       (case modifier
1394                         ((colon)
1395                          (if (not format:fn-pos?)
1396                              (format:out-char #\-))
1397                          (format:out-fill (- width numlen) (integer->char padch)))
1398                         ((at)
1399                          (format:out-fill (- width numlen) (integer->char padch))
1400                          (format:out-char (if format:fn-pos? #\+ #\-)))
1401                         ((colon-at)
1402                          (format:out-char (if format:fn-pos? #\+ #\-))
1403                          (format:out-fill (- width numlen) (integer->char padch)))
1404                         (else
1405                          (format:out-fill (- width numlen) (integer->char padch))
1406                          (if (not format:fn-pos?)
1407                              (format:out-char #\-))))
1408                       (if format:fn-pos?
1409                           (if (memq modifier '(at colon-at)) (format:out-char #\+))
1410                           (format:out-char #\-))))
1411                 (if (and mindig (> mindig format:fn-dot))
1412                     (format:out-fill (- mindig format:fn-dot) #\0))
1413                 (if (and (= format:fn-dot 0) (not mindig))
1414                     (format:out-char #\0))
1415                 (format:out-substr format:fn-str 0 format:fn-dot)
1416                 (format:out-char #\.)
1417                 (format:out-substr format:fn-str format:fn-dot format:fn-len)))))))
1418
1419                                         ; the flonum buffers
1420
1421        (format:fn-max 400)              ; max. number of number digits
1422        (format:fn-str #f) ; number buffer
1423        (format:fn-len 0)                ; digit length of number
1424        (format:fn-dot #f)               ; dot position of number
1425        (format:fn-pos? #t)              ; number positive?
1426        (format:en-max 10)               ; max. number of exponent digits
1427        (format:en-str #f) ; exponent buffer
1428        (format:en-len 0)                ; digit length of exponent
1429        (format:en-pos? #t)              ; exponent positive?
1430
1431        (format:parse-float
1432         (lambda (num-str fixed? scale)
1433                  (set! format:fn-pos? #t)
1434                  (set! format:fn-len 0)
1435                  (set! format:fn-dot #f)
1436                  (set! format:en-pos? #t)
1437                  (set! format:en-len 0)
1438                  (do ((i 0 (+ i 1))
1439                       (left-zeros 0)
1440                       (mantissa? #t)
1441                       (all-zeros? #t)
1442                       (num-len (string-length num-str))
1443                       (c #f))                   ; current exam. character in num-str
1444                      ((= i num-len)
1445                       (if (not format:fn-dot)
1446                           (set! format:fn-dot format:fn-len))
1447
1448                       (if all-zeros?
1449                           (begin
1450                             (set! left-zeros 0)
1451                             (set! format:fn-dot 0)
1452                             (set! format:fn-len 1)))
1453
1454                       ;; now format the parsed values according to format's need
1455
1456                       (if fixed?
1457
1458                           (begin                        ; fixed format m.nnn or .nnn
1459                             (if (and (> left-zeros 0) (> format:fn-dot 0))
1460                                 (if (> format:fn-dot left-zeros)
1461                                     (begin              ; norm 0{0}nn.mm to nn.mm
1462                                       (format:fn-shiftleft left-zeros)
1463                                       (set! format:fn-dot (- format:fn-dot left-zeros))
1464                                       (set! left-zeros 0))
1465                                     (begin              ; normalize 0{0}.nnn to .nnn
1466                                       (format:fn-shiftleft format:fn-dot)
1467                                       (set! left-zeros (- left-zeros format:fn-dot))
1468                                       (set! format:fn-dot 0))))
1469                             (if (or (not (= scale 0)) (> format:en-len 0))
1470                                 (let ((shift (+ scale (format:en-int))))
1471                                   (cond
1472                                    (all-zeros? #t)
1473                                    ((> (+ format:fn-dot shift) format:fn-len)
1474                                     (format:fn-zfill
1475                                      #f (- shift (- format:fn-len format:fn-dot)))
1476                                     (set! format:fn-dot format:fn-len))
1477                                    ((< (+ format:fn-dot shift) 0)
1478                                     (format:fn-zfill #t (- (- shift) format:fn-dot))
1479                                     (set! format:fn-dot 0))
1480                                    (else
1481                                     (if (> left-zeros 0)
1482                                         (if (<= left-zeros shift) ; shift always > 0 here
1483                                             (format:fn-shiftleft shift) ; shift out 0s
1484                                             (begin
1485                                               (format:fn-shiftleft left-zeros)
1486                                               (set! format:fn-dot (- shift left-zeros))))
1487                                         (set! format:fn-dot (+ format:fn-dot shift))))))))
1488
1489                           (let ((negexp         ; expon format m.nnnEee
1490                                  (if (> left-zeros 0)
1491                                      (- left-zeros format:fn-dot -1)
1492                                      (if (= format:fn-dot 0) 1 0))))
1493                             (if (> left-zeros 0)
1494                                 (begin                  ; normalize 0{0}.nnn to n.nn
1495                                   (format:fn-shiftleft left-zeros)
1496                                   (set! format:fn-dot 1))
1497                                 (if (= format:fn-dot 0)
1498                                     (set! format:fn-dot 1)))
1499                             (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
1500                                               negexp))
1501                             (cond
1502                              (all-zeros?
1503                               (format:en-set 0)
1504                               (set! format:fn-dot 1))
1505                              ((< scale 0)               ; leading zero
1506                               (format:fn-zfill #t (- scale))
1507                               (set! format:fn-dot 0))
1508                              ((> scale format:fn-dot)
1509                               (format:fn-zfill #f (- scale format:fn-dot))
1510                               (set! format:fn-dot scale))
1511                              (else
1512                               (set! format:fn-dot scale)))))
1513                       #t)
1514
1515                    ;; do body
1516                    (set! c (string-ref num-str i))      ; parse the output of number->string
1517                    (cond                                ; which can be any valid number
1518                     ((char-numeric? c)                  ; representation of R4RS except
1519                      (if mantissa?                      ; complex numbers
1520                          (begin
1521                            (if (char=? c #\0)
1522                                (if all-zeros?
1523                                    (set! left-zeros (+ left-zeros 1)))
1524                                (begin
1525                                  (set! all-zeros? #f)))
1526                            (string-set! format:fn-str format:fn-len c)
1527                            (set! format:fn-len (+ format:fn-len 1)))
1528                          (begin
1529                            (string-set! format:en-str format:en-len c)
1530                            (set! format:en-len (+ format:en-len 1)))))
1531                     ((or (char=? c #\-) (char=? c #\+))
1532                      (if mantissa?
1533                          (set! format:fn-pos? (char=? c #\+))
1534                          (set! format:en-pos? (char=? c #\+))))
1535                     ((char=? c #\.)
1536                      (set! format:fn-dot format:fn-len))
1537                     ((char=? c #\e)
1538                      (set! mantissa? #f))
1539                     ((char=? c #\E)
1540                      (set! mantissa? #f))
1541                     ((char-whitespace? c) #t)
1542                     ((char=? c #\d) #t)         ; decimal radix prefix
1543                     ((char=? c #\#) #t)
1544                     (else
1545                      (format:error "illegal character `~c' in number->string" c))))))
1546
1547        (format:en-int
1548         (lambda ()                      ; convert exponent string to integer
1549           (if (= format:en-len 0)
1550               0
1551               (do ((i 0 (+ i 1))
1552                    (n 0))
1553                   ((= i format:en-len)
1554                    (if format:en-pos?
1555                        n
1556                        (- n)))
1557                 (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
1558                                        format:zero-ch)))))))
1559
1560        (format:en-set          ; set exponent string number
1561         (lambda (en)
1562           (set! format:en-len 0)
1563           (set! format:en-pos? (>= en 0))
1564           (let ((en-str (number->string en)))
1565             (do ((i 0 (+ i 1))
1566                  (en-len (string-length en-str))
1567                  (c #f))
1568                 ((= i en-len))
1569               (set! c (string-ref en-str i))
1570               (if (char-numeric? c)
1571                   (begin
1572                     (string-set! format:en-str format:en-len c)
1573                     (set! format:en-len (+ format:en-len 1))))))))
1574
1575        (format:fn-zfill ; fill current number string with 0s
1576         (lambda (left? n)
1577           (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
1578               (format:error "number is too long to format (enlarge format:fn-max)"))
1579           (set! format:fn-len (+ format:fn-len n))
1580           (if left?
1581               (do ((i format:fn-len (- i 1)))   ; fill n 0s to left
1582                   ((< i 0))
1583                 (string-set! format:fn-str i
1584                              (if (< i n)
1585                                  #\0
1586                                  (string-ref format:fn-str (- i n)))))
1587               (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
1588                   ((= i format:fn-len))
1589                 (string-set! format:fn-str i #\0)))))
1590
1591        (format:fn-shiftleft             ; shift left current number n positions
1592         (lambda (n)
1593           (if (> n format:fn-len)
1594               (format:error "internal error in format:fn-shiftleft (~d,~d)"
1595                             n format:fn-len))
1596           (do ((i n (+ i 1)))
1597               ((= i format:fn-len)
1598                (set! format:fn-len (- format:fn-len n)))
1599             (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))))
1600
1601        (format:fn-round ; round format:fn-str
1602         (lambda (digits)
1603           (set! digits (+ digits format:fn-dot))
1604           (do ((i digits (- i 1))               ; "099",2 -> "10"
1605                (c 5))                           ; "023",2 -> "02"
1606               ((or (= c 0) (< i 0))             ; "999",2 -> "100"
1607                (if (= c 1)                      ; "005",2 -> "01"
1608                    (begin                       ; carry overflow
1609                      (set! format:fn-len digits)
1610                      (format:fn-zfill #t 1)     ; add a 1 before fn-str
1611                      (string-set! format:fn-str 0 #\1)
1612                      (set! format:fn-dot (+ format:fn-dot 1)))
1613                    (set! format:fn-len digits)))
1614             (set! c (+ (- (char->integer (string-ref format:fn-str i))
1615                           format:zero-ch) c))
1616             (string-set! format:fn-str i (integer->char
1617                                           (if (< c 10)
1618                                               (+ c format:zero-ch)
1619                                               (+ (- c 10) format:zero-ch))))
1620             (set! c (if (< c 10) 0 1)))))
1621
1622        (format:fn-out
1623         (lambda (modifier add-leading-zero?)
1624           (if format:fn-pos?
1625               (if (eq? modifier 'at)
1626                   (format:out-char #\+))
1627               (format:out-char #\-))
1628           (if (= format:fn-dot 0)
1629               (if add-leading-zero?
1630                   (format:out-char #\0))
1631               (format:out-substr format:fn-str 0 format:fn-dot))
1632           (format:out-char #\.)
1633           (format:out-substr format:fn-str format:fn-dot format:fn-len)))
1634
1635        (format:en-out
1636         (lambda (edigits expch)
1637           (format:out-char (if expch (integer->char expch) format:expch))
1638           (format:out-char (if format:en-pos? #\+ #\-))
1639           (if edigits
1640               (if (< format:en-len edigits)
1641                   (format:out-fill (- edigits format:en-len) #\0)))
1642           (format:out-substr format:en-str 0 format:en-len)))
1643
1644        (format:fn-strip         ; strip trailing zeros but one
1645         (lambda ()
1646           (string-set! format:fn-str format:fn-len #\0)
1647           (do ((i format:fn-len (- i 1)))
1648               ((or (not (char=? (string-ref format:fn-str i) #\0))
1649                    (<= i format:fn-dot))
1650                (set! format:fn-len (+ i 1))))))
1651
1652        (format:fn-zlead         ; count leading zeros
1653         (lambda ()
1654           (do ((i 0 (+ i 1)))
1655               ((or (= i format:fn-len)
1656                    (not (char=? (string-ref format:fn-str i) #\0)))
1657                (if (= i format:fn-len)          ; found a real zero
1658                    0
1659                    i)))))
1660
1661
1662 ;;; some global functions not found in SLIB
1663
1664        (string-capitalize-first ; "hello" -> "Hello"
1665         (lambda (str)
1666           (let ((cap-str (string-copy str))     ; "hELLO" -> "Hello"
1667                 (non-first-alpha #f)            ; "*hello" -> "*Hello"
1668                 (str-len (string-length str)))  ; "hello you" -> "Hello you"
1669             (do ((i 0 (+ i 1)))
1670                 ((= i str-len) cap-str)
1671               (let ((c (string-ref str i)))
1672                 (if (char-alphabetic? c)
1673                     (if non-first-alpha
1674                         (string-set! cap-str i (char-downcase c))
1675                         (begin
1676                           (set! non-first-alpha #t)
1677                           (string-set! cap-str i (char-upcase c))))))))))
1678
1679        ;; Aborts the program when a formatting error occures. This is a null
1680        ;; argument closure to jump to the interpreters toplevel continuation.
1681
1682        (format:abort (lambda () (error "error in format"))))
1683
1684     (set! format:error-save format:error)
1685     (set! format:fn-str (make-string format:fn-max)) ; number buffer
1686     (set! format:en-str (make-string format:en-max)) ; exponent buffer
1687     (apply format:format args)))
1688
1689 ;; Thanks to Shuji Narazaki
1690 (module-set! the-root-module 'format format)