Changeset 39878 in project


Ignore:
Timestamp:
04/07/21 15:43:33 (2 weeks ago)
Author:
Kon Lovett
Message:

revert version, use new test runner

Location:
release/5/format/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/format/trunk/format.egg

    r39792 r39878  
    11;;;; -*- scheme -*-
    2 ;;;; format.egg
     2;;;; format.meta
    33
    44((synopsis "Common-Lisp style formatted output")
    5  (version "3.3.0")
    65 (author "Dirk Lutzebeck")
    76 (license "Public Domain")
    8  (maintainer "[[felix winkelmann]], [[kon lovett]]")
    9  (dependencies srfi-13 utf8)
    10  (test-dependencies test)
     7 (maintainer "felix winkelmann, kon lovett")
     8 (build-dependencies srfi-13)
    119 (category io)
    12  ;FIXME -strict-types fails some tests
    13  (components
    14   (extension format
    15    (types-file)
    16    (csc-options "-O3" "-d1" "-strict-types" "-no-bound-checks" "-no-argc-checks" "-no-procedure-checks"))
    17   (extension utf8-format
    18    (types-file)
    19    (csc-options "-O3" "-d1" "-strict-types" "-no-bound-checks" "-no-argc-checks" "-no-procedure-checks"))))
     10 (components (extension format (csc-options "-O2" "-d1"))))
  • release/5/format/trunk/format.scm

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

    r38474 r39878  
    1 ;;;; format-test.scm
    2 
    31(import scheme)
    4 
    5 (import test)
    6 
    7 (test-begin "Format")
    8 
     2(import (chicken format))
    93(import format)
    104
    11 ;;;
     5(define *passed* 0)
     6(define *failed* 0)
    127
    13 (import (only (chicken string) ->string))
    14 
    15 (define (format-test expected . rest)
    16         (test (->string rest) expected (apply format #f rest)) )
     8(define (test expected . rest)
     9        (let ([result (apply format #f rest)])
     10                (if (string=? result expected)
     11                        (begin
     12                                (set! *passed* (add1 *passed*))
     13                                (printf "Passed: (~S)~%Produce: ~S~%Expect:  ~S~%~%" rest result expected))
     14                        (begin
     15                                (set! *failed* (add1 *failed*))
     16                                (printf "Failed: (~S)~%Produce: ~S~%Expect:  ~S~%~%" rest result expected)))))
    1717
    1818; make sure both ~A and ~a work:
    19 (format-test "hey there" "~a ~A" "hey" "there")
     19(test "hey there" "~a ~A" "hey" "there")
    2020
    21 (format-test "7 tries/1 win" "~D tr~:@P/~D win~:P" 7 1)
    22 (format-test "1 try/0 wins" "~D tr~:@P/~D win~:P" 1 0)
    23 (format-test "1 try/1 win" "~D tr~:@P/~D win~:P" 1 1)
    24 (format-test "2 tries/3 wins" "~D tr~:@P/~D win~:P" 2 3)
     21(test "7 tries/1 win" "~D tr~:@P/~D win~:P" 7 1)
     22(test "1 try/0 wins" "~D tr~:@P/~D win~:P" 1 0)
     23(test "1 try/1 win" "~D tr~:@P/~D win~:P" 1 1)
     24(test "2 tries/3 wins" "~D tr~:@P/~D win~:P" 2 3)
    2525
    26 (format-test "Results: NONE\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%")
    27 (format-test "Results: 1\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%" 1)
    28 (format-test "Results: 1 and 2\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%" 1 2)
    29 (format-test "Results: 1, 2 and 3\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%" 1 2 3)
     26(test "Results: NONE\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%")
     27(test "Results: 1\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%" 1)
     28(test "Results: 1 and 2\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%" 1 2)
     29(test "Results: 1, 2 and 3\n" "Results: ~#[NONE~;~A~;~A ~0[and~;y~] ~A~;~A, ~A and ~A~]~%" 1 2 3)
    3030
    31 (format-test "Zero" "~0[Zero~;One~:;Other~]")
    32 (format-test "One" "~1[Zero~;One~:;Other~]")
    33 (format-test "Other" "~2[Zero~;One~:;Other~]")
    34 (format-test "Other" "~999[Zero~;One~:;Other~]")
     31(test "Zero" "~0[Zero~;One~:;Other~]")
     32(test "One" "~1[Zero~;One~:;Other~]")
     33(test "Other" "~2[Zero~;One~:;Other~]")
     34(test "Other" "~999[Zero~;One~:;Other~]")
    3535
    36 (format-test "[false]" "[~:[false~;true~]]" #f)
    37 (format-test "[true]" "[~:[false~;true~]]" 34)
    38 (format-test "[]" "[~@[true~]]" #f)
    39 (format-test "[true]" "[~@[true~]]" 39)
     36(test "[false]" "[~:[false~;true~]]" #f)
     37(test "[true]" "[~:[false~;true~]]" 34)
     38(test "[]" "[~@[true~]]" #f)
     39(test "[true]" "[~@[true~]]" 39)
    4040
    41 (format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5) 7)
    42 (format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5 14) 7)
    43 (format-test "<Foo 5> 7" "~@? ~D" "<~A ~D>" "Foo" 5 7)
     41(test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5) 7)
     42(test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5 14) 7)
     43(test "<Foo 5> 7" "~@? ~D" "<~A ~D>" "Foo" 5 7)
    4444;;Error: (format) 1: "superfluous arguments"
    4545;;when configured w/ format:unprocessed-arguments-error? = #t
    46 (format-test "<Foo 5> 14" "~@? ~D" "<~A ~D>" "Foo" 5 14 7)
     46(test "<Foo 5> 14" "~@? ~D" "<~A ~D>" "Foo" 5 14 7)
    4747
    48 (format-test "The winners are: fred harry jill." "The winners are:~{ ~S~}." '(fred harry jill))
     48(test "The winners are: fred harry jill." "The winners are:~{ ~S~}." '(fred harry jill))
    4949
    50 (format-test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3))
    51 (format-test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3)))
    52 (format-test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3)
    53 (format-test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3))
     50(test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3))
     51(test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3)))
     52(test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~@{ <~S,~S>~}." 'a 1 'b 2 'c 3)
     53(test "Pairs: <a,1> <b,2> <c,3>." "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3))
    5454
    55 (format-test "[]" "[~{hey~}]" '())
     55(test "[]" "[~{hey~}]" '())
    5656
    57 (format-test "Done." "Done.~^  ~D warning~:P.~^  ~D error~:P." )
    58 (format-test "Done.  3 warnings." "Done.~^  ~D warning~:P.~^  ~D error~:P." 3)
    59 (format-test "Done.  1 warning.  5 errors." "Done.~^  ~D warning~:P.~^  ~D error~:P." 1 5)
     57(test "Done." "Done.~^  ~D warning~:P.~^  ~D error~:P." )
     58(test "Done.  3 warnings." "Done.~^  ~D warning~:P.~^  ~D error~:P." 3)
     59(test "Done.  1 warning.  5 errors." "Done.~^  ~D warning~:P.~^  ~D error~:P." 1 5)
    6060
    61 (format-test "/hot .../hamburger/ice .../french ..." "~:{/~S~^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries)))
     61(test "/hot .../hamburger/ice .../french ..." "~:{/~S~^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries)))
    6262
    6363;;Error: (format) 1: "superfluous arguments"
    6464;;when configured w/ format:unprocessed-arguments-error? = #t
    65 (format-test "None" "~[None~;~:{/~S~^...~}~]" 0 '((h e) (d) (h d)))
     65(test "None" "~[None~;~:{/~S~^...~}~]" 0 '((h e) (d) (h d)))
    6666
    67 (format-test "/h.../d/h..." "~[None~;~:{/~S~^...~}~]" 1 '((h e) (d) (h d)))
     67(test "/h.../d/h..." "~[None~;~:{/~S~^...~}~]" 1 '((h e) (d) (h d)))
    6868
    69 (format-test "TheData: 0" "~1{~:}" "TheData: ~A" '(0))
     69(test "TheData: 0" "~1{~:}" "TheData: ~A" '(0))
    7070
    7171;;Failed: Produce: [0][1][2][3][4] Expect: [0][1]
    7272;;when configured w/ format:iteration-bounded = #f
    73 (format-test "[0][1]" "~2{[~A]~}" '(0 1 2 3 4))
     73(test "[0][1]" "~2{[~A]~}" '(0 1 2 3 4))
    7474
    75 (format-test "a \n a ^J #\\a #\\newline" "~C ~C ~:C ~:C ~@C ~@C" #\a #\newline #\a #\newline #\a #\newline)
     75(test "a \n a ^J #\\a #\\newline" "~C ~C ~:C ~:C ~@C ~@C" #\a #\newline #\a #\newline #\a #\newline)
    7676
    77 (format-test "XXIII MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMCCCLXXXIIII DCCCCXXIII" "~:@R ~:@R ~:@R" 23 32384 923)
    78 (format-test "MCMLXXX IV CCCXCIII MMMMMMMMMCCXXXIX" "~@R ~@R ~@R ~@R" 1980 4 393 9239)
     77(test "XXIII MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMCCCLXXXIIII DCCCCXXIII" "~:@R ~:@R ~:@R" 23 32384 923)
     78(test "MCMLXXX IV CCCXCIII MMMMMMMMMCCXXXIX" "~@R ~@R ~@R ~@R" 1980 4 393 9239)
    7979
    80 (format-test "one hundred twenty-eight zero two million, nine hundred thirty-eight thousand, three hundred twenty-eight nine thousand, two hundred thirty-eight two thousand, eight hundred thirty-nine thirty-eight three thousand, eight hundred twenty-eight" "~R ~R ~R ~R ~R ~R ~R" 128 0 2938328 9238 2839 38 3828)
    81 (format-test "one hundred twenty-eighth zeroth two million, nine hundred thirty-eight thousand, three hundred twenty-eighth nine thousand, two hundred thirty-eighth two thousand, eight hundred thirty-ninth thirty-eighth three thousand, eight hundred twentieth" "~:R ~:R ~:R ~:R ~:R ~:R ~:R" 128 0 2938328 9238 2839 38 3820)
     80(test "one hundred twenty-eight zero two million, nine hundred thirty-eight thousand, three hundred twenty-eight nine thousand, two hundred thirty-eight two thousand, eight hundred thirty-nine thirty-eight three thousand, eight hundred twenty-eight" "~R ~R ~R ~R ~R ~R ~R" 128 0 2938328 9238 2839 38 3828)
     81(test "one hundred twenty-eighth zeroth two million, nine hundred thirty-eight thousand, three hundred twenty-eighth nine thousand, two hundred thirty-eighth two thousand, eight hundred thirty-ninth thirty-eighth three thousand, eight hundred twentieth" "~:R ~:R ~:R ~:R ~:R ~:R ~:R" 128 0 2938328 9238 2839 38 3820)
    8282
    83 (format-test " -68." "~5,0F" -67.77)
    84 (format-test "-67.8" "~5,1F" -67.77)
    85 (format-test "1.000" "~,3F" 1)
    86 (format-test "1.0" "~F" 1)
    87 (format-test "***" "~3,3,0,'*F" 2)
    88 (format-test "1234.0" "~,,3F" 1.234)
     83(test " -68." "~5,0F" -67.77)
     84(test "-67.8" "~5,1F" -67.77)
     85(test "1.000" "~,3F" 1)
     86(test "1.0" "~F" 1)
     87(test "***" "~3,3,0,'*F" 2)
     88(test "1234.0" "~,,3F" 1.234)
    8989
    90 (define (format-F-test expected x)
    91   (format-test expected "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x))
     90(define (foo expected x)
     91  (test expected "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x))
    9292
    93 (format-F-test "  3.14| 31.42|  3.14|3.1416|3.14|3.14159" 3.14159)
    94 (format-F-test " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" -3.14159)
    95 (format-F-test "100.00|******|100.00| 100.0|100.00|100.0" 100.0)
    96 (format-F-test "1234.00|******|??????|1234.0|1234.00|1234.0" 1234.0)
    97 (format-F-test "  0.01|  0.06|  0.01| 0.006|0.01|0.006" 0.006)
     93(foo "  3.14| 31.42|  3.14|3.1416|3.14|3.14159" 3.14159)
     94(foo " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" -3.14159)
     95(foo "100.00|******|100.00| 100.0|100.00|100.0" 100.0)
     96(foo "1234.00|******|??????|1234.0|1234.00|1234.0" 1234.0)
     97(foo "  0.01|  0.06|  0.01| 0.006|0.01|0.006" 0.006)
    9898
    99 (format-test "1.23243E+2" "~E" 123.243)
    100 (format-test "1.0E+0" "~E" 1)
    101 (format-test "    1.0E+0" "~10E" 1)
    102 (format-test "1.000E+0" "~,3E" 1)
    103 (format-test "1.0E-4" "~E" 0.0001)
    104 (format-test "2.3E+00001" "~,,5E" 23)
    105 (format-test "===" "~3,,,,'=E" 23)
    106 (format-test "####2.3E+1" "~10,,,,,'#E" 23)
    107 (format-test "1.0$+0" "~,,,,,,'$E" 1)
     99(test "1.23243E+2" "~E" 123.243)
     100(test "1.0E+0" "~E" 1)
     101(test "    1.0E+0" "~10E" 1)
     102(test "1.000E+0" "~,3E" 1)
     103(test "1.0E-4" "~E" 0.0001)
     104(test "2.3E+00001" "~,,5E" 23)
     105(test "===" "~3,,,,'=E" 23)
     106(test "####2.3E+1" "~10,,,,,'#E" 23)
     107(test "1.0$+0" "~,,,,,,'$E" 1)
    108108
    109 (define (format-E-test expected x)
    110   (format-test expected "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" x x x x))
     109(define (foo expected x)
     110  (test expected "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" x x x x))
    111111
    112112;; Fixed - wasn't leaving off leading 0 when result-len > len so considered overflow
    113 (format-E-test "  3.14E+0| 31.42$-01|+.003E+03|  3.14E+0" 3.14159)
    114 (format-E-test " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" -3.14159)
    115 (format-E-test "  1.10E+3| 11.00$+02|+.001E+06|  1.10E+3" 1100.0)
    116 (format-E-test "*********| 11.00$+12|+.001E+16| 1.10E+13" 1.1E13)
     113(foo "  3.14E+0| 31.42$-01|+.003E+03|  3.14E+0" 3.14159)
     114(foo " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" -3.14159)
     115(foo "  1.10E+3| 11.00$+02|+.001E+06|  1.10E+3" 1100.0)
     116(foo "*********| 11.00$+12|+.001E+16| 1.10E+13" 1.1E13)
    117117
    118 (define (format-G-test expected x)
    119   (format-test expected "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" x x x x))
     118(define (foo expected x)
     119  (test expected "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" x x x x))
    120120
    121 (format-G-test  "  3.14E-2|314.2$-04|0.314E-01|  3.14E-2" 0.0314159)
    122 (format-G-test  "  3.14E+3|314.2$+01|0.314E+04|  3.14E+3" 3141.59)
    123 (format-G-test  "  0.31   |0.314    |0.314    | 0.31    " 0.314159)
    124 (format-G-test  "   3.1   | 3.14    | 3.14    |  3.1    " 3.14159)
    125 (format-G-test  "   31.   | 31.4    | 31.4    |  31.    " 31.4159)
    126 (format-G-test  "  3.14E+2| 314.    | 314.    |  3.14E+2" 314.159)
    127 (format-G-test  "*********|314.0$+10|0.314E+13| 3.14E+12" 3.14E12)
     121(foo  "  3.14E-2|314.2$-04|0.314E-01|  3.14E-2" 0.0314159)
     122(foo  "  3.14E+3|314.2$+01|0.314E+04|  3.14E+3" 3141.59)
     123(foo  "  0.31   |0.314    |0.314    | 0.31    " 0.314159)
     124(foo  "   3.1   | 3.14    | 3.14    |  3.1    " 3.14159)
     125(foo  "   31.   | 31.4    | 31.4    |  31.    " 31.4159)
     126(foo  "  3.14E+2| 314.    | 314.    |  3.14E+2" 314.159)
     127(foo  "*********|314.0$+10|0.314E+13| 3.14E+12" 3.14E12)
    128128
    129 (format-test " "         "~T")
    130 (format-test "  "        "  ~T")
    131 (format-test "    "      "~4T")
    132 (format-test "     "     "  ~5,6T")
    133 (format-test "        "  "      ~4,4T")
    134 (format-test "        "  "     ~4,4T")
     129(test " "         "~T")
     130(test "  "        "  ~T")
     131(test "    "      "~4T")
     132(test "     "     "  ~5,6T")
     133(test "        "  "      ~4,4T")
     134(test "        "  "     ~4,4T")
    135135;; the original test was wrong
    136 (format-test "       "    "     ~4,3T")
    137 (format-test "    "      "~4,4@T")
    138 (format-test "      "    "~4,3@T")
    139 (format-test "         " "   ~4,3@T")
     136(test "       "    "     ~4,3T")
     137(test "    "      "~4,4@T")
     138(test "      "    "~4,3@T")
     139(test "         " "   ~4,3@T")
    140140
    141 ;;;
     141(printf "Passed: ~S Failed: ~S~%" *passed* *failed*)
    142142
    143 (test-end "Format")
    144 
    145 (test-exit)
     143(exit (if (not (zero? *failed*)) 1 0))
  • release/5/format/trunk/tests/run-ident.scm

    r39792 r39878  
    44(define *csc-incl-options* '())
    55(define *csc-excl-options* '())
    6 (define *test-excl-names* '("format" "utf8-format"))
     6(define *test-excl-names* '())
Note: See TracChangeset for help on using the changeset viewer.