module/ice-9/format.scm

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