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