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