sprintf

An implementation of sprintf, printf and fprintf



\ Run the sprintf test program

s" sprintf.fth" included
s" tester.fr" included
decimal

\ sprintf test program

sprintf-words

\ ---[ Test helpers ]-----------------------------------------------------------

create (buf) 128 allot
variable blen

: >buf  ( caddr u -- )  dup blen ! (buf) swap cmove ;

\ *** Do not use B" inside a colon definition - it wasn't intended to be
\ *** compiled and so doesn't work

: b"  ( -- caddr u )    \ Parse and copy a string to (buf)
   (buf) '"' parse tuck >buf
;

: buf$  ( -- caddr u )  (buf) blen @ ;
: buf$+  ( u1 --  caddr u2 )  buf$ rot /string ;
\ Note: 0 buf$+ is equivalent to buf$

: .stack  ( -- )
   depth ?dup 0>
   if
      ." Stack contents: ( "
      dup 6 > if drop 6 ." ... " then
      0 swap                  ( -- xn ... x0 0 n )
      ?do
         i ?dup 0>
         if 1- pick . then
         -1
      +loop      
      ')' emit
      depth 6 > if ."  Depth: " depth . then
   else
      ." Stack empty"
   then
;

fp-enabled
[if]
   : .fpstack  ( -- )  ." FP stack depth: " fdepth 6 .r  ;
[else]
   : .fpstack  ( -- )  ." No floating point"  ;
[then]

: >lower  ( caddr u -- caddr u ) \ Digits converted to lower case
   2dup over + swap
   ?do i c@ char>lower i c! loop  \ char>lower in sprint-buffer.fth
;

: >upper  ( caddr u -- caddr u ) \ Digits converted to upper case
   2dup over + swap
   ?do i c@ char>upper i c! loop  \ char>lower in sprint-buffer.fth
;

0 #errors !
variable #tests 0 #tests !
: t{  ( -- )  1 #tests +! t{  ;

\ ---[ Start of tests ]---------------------------------------------------------

cr .( Start of tests) cr
Testing stack frames

t{ set-frame -> }t
t{ set-frame 1 0 arg -> 1 1 }t
t{ set-frame 2 3 4 1 arg 0 arg -> 2 3 4 3 2 }t
t{ 5 6 7 set-frame 8 9 0 arg 1 arg -> 5 6 7 8 9 8 9 }t
t{ 10 set-frame 11 12 13 14 1 arg 0 arg 2 arg -> 10 11 12 13 14 12 11 13 }t
t{ 15 set-frame drop-frame -> 15 }t
t{ 16 17 set-frame 18 19 20 drop-frame -> 16 17 }t

t{ 21 field fld21 -> 20 }t
t{ begin-frame
      field fld0
      field fld1
      field fld2
      field fld3
   end-frame frm1 -> }t
t{ frm1 -> 4 }t
t{ 22 23 set-frame 24 25 26 27 28 fld0 fld3 fld1 fld2
                     -> 22 23 24 25 26 27 28 24 27 25 26 }t

t{ frame{ fld4 fld5 fld6 } frm2 -> }t
t{ frm2 -> 3 }t
t{ 29 set-frame 30 31 32 33 fld4 fld5 fld6 -> 29 30 31 32 33 30 31 32 }t

t{ 34 2field 2fld0 -> 32 }t
t{ begin-frame field fld7 2field fld8 field fld9 end-frame frm3 -> }t
t{ set-frame 35 b" abcde" 36 fld8 fld9 fld7 -> 35 buf$ 36 buf$ 36 35 }t

fp-enabled [if]
Testing the FP argument array

\ Ensure the FP stack is empty
: clear-fp-stack  ( F: rn ...r0 -- )  fdepth 0 ?do fdrop loop ;
clear-fp-stack

2e0 2e1 2e2 \ Use powers of 2 so that F- result below is exactly fp zero
t{ 3 floats move-fp-args fdepth -> 0 }t
t{ 0 floats get-fp-arg 2e0 f- fabs f0= -> true }t
t{ 1 floats get-fp-arg 2e1 f- fabs f0= -> true }t
t{ 2 floats get-fp-arg 2e2 f- fabs f0= -> true }t
t{ fdepth -> 0 }t
[then]

Testing flag definitions

\ The numbers 1 to 6 represent the stack frame fields below the flags field
: new-frame ( n -- )  >r set-frame 1 2 3 4 5 6 r>  ; \ n is flags value

t{ 0 #flag+ -> #flag@ }t
t{ 0 #flag+ ucflag+ +flag+ -> +flag@ #flag@ or ucflag@ or }t
t{ leftflag@ new-frame #flag -> 1 2 3 4 5 6 leftflag@ 0 }t
t{ blflag@ new-frame blflag -> 1 2 3 4 5 6 blflag@ dup }t
t{ numflag@ 2* 1- new-frame numflag 0flag longflag
            -> 1 2 3 4 5 6 1023 numflag@ 0flag@ longflag@ }t
t{ $157 new-frame precflag caseflag or leftflag or -> 1 2 3 4 5 6 $157 0  }t

Testing sprintf buffer

256 constant sprb-size create test-buf sprb-size allot
t{ test-buf sprb-size set-sprintf-buffer -> }t
t{ sprbuf$ -> test-buf 0 }t
t{ sprbuf-unused -> sprb-size }t
t{ sprbuf-clear -> }t
t{ sprbuf-here -> sprbuf }t
t{ sprbuf-unused -> sprbuf-size }t
t{ sprbuf$ -> sprbuf 0 }t
t{ b" abcde" sprbuf+ -> }t
t{ sprbuf$ buf$ compare -> 0 }t
t{ sprbuf-here -> sprbuf buf$ nip chars + }t
t{ sprbuf-unused -> sprbuf-size buf$ nip - }t
t{ 'f' char>sprbuf -> }t
t{ sprbuf$ b" abcdef" compare -> 0 }t
t{ sprbuf-unused -> sprbuf-size buf$ nip - }t
t{ sprbuf-clear here sprbuf-size sprbuf+ -> }t
t{ sprbuf-unused -> 0 }t
t{ :noname 'x' char>sprbuf ; catch -> buf-overflow }t
t{ :noname sprbuf-clear here sprbuf-size 1+ sprbuf+ ; catch -> buf-overflow }t
t{ sprbuf-clear b" One" sprbuf+ bl char>sprbuf b" Two" sprbuf+
        sprbuf$ b" One Two" compare -> 0 }t
: sprb-lower s" @`abcdefghijklmnopqrstuvwxyz[{+" ;
: sprb-upper s" @`ABCDEFGHIJKLMNOPQRSTUVWXYZ[{+" ;
t{ sprbuf-clear sprb-lower >buf buf$ str>upper sprb-upper compare -> 0 }t
t{ sprbuf-clear sprb-lower >buf buf$ str>lower sprb-lower compare -> 0 }t
t{ sprbuf-clear sprb-upper >buf buf$ str>lower sprb-lower compare -> 0 }t
t{ sprbuf-clear sprb-upper >buf buf$ str>upper sprb-upper compare -> 0 }t
 
Testing input scanner NEXT-CHAR PREV-CHAR NEXTSYM ?NEXTSYM TEST-TOKEN TESTSYM?

: getsym  ( -- sym )  nextsym sym @  ;
: getnsyms  ( n -- n0 .. nn-1 )  0 do getsym loop  ;
: ?getsym ( f -- sym | error ) ?nextsym sym @ ; 
: tgs  ( n -- n0 .. nn-1 )  ['] getnsyms execute-parsing ;

t{ next-char a next-char b -> 'a' 'b' }t
\ The next 3 lines need the LF between NEXT-CHAR and '->'. Do not change
t{ next-char c next-char
    -> 'c' -1 }t  \ No next character, no space at end of the previous line
t{ next-char 
    -> -1 }t  \ No next character, one space at end of the previous line
t{ next-char  
    -> bl }t  \ No next character, two spaces at end of previous line
t{ 8 getnsyms # %*+-.0 -> "#" "bl" "%" "*" "+" "-" "." "0" }t
t{ 8 getnsyms 12345678 -> "1-9" "1-9" "1-9" "1-9" "1-9" "1-9" "1-9" "1-9" }t
t{ 8 getnsyms 9EGXbcde -> "1-9" "UE" "UG" "UX" "b" "c" "d" "e" }t
t{ 8 getnsyms fglosux
     -> "f" "g" "l" "o" "s" "u" "x" -1 }t    \ Do not change these 2 lines
t{ 4 getnsyms !$S~ -> 0 0 0 0 }t
create oor-chs 0 c, #31 c, #128 c, #255 c,  \ Out of range chars
t{ oor-chs 4  >buf 4 buf$ tgs -> 0 0 0 0 }t   \ Test out of range
t{ true ?getsym s -> 19 }t
t{ :noname  0 ?getsym ; catch invalid-char = [if] 40 [else] 41 [then] -> 40 }t

t{ getsym x "x" test-token -> "x" true  }t
t{ getsym y  26 test-token ->  0  false }t

t{ getsym c 16 testsym? 0<> -> "c" true }t
t{ getsym % 20 testsym? 0<> -> "%" false }t

: pct  2 getnsyms prev-char getsym ;      \ Testing PREV-CHAR
t{ b" uds" ' pct execute-parsing -> "u" "d" "d" }t

Testing parse-format

: pf  ( caddr u -- width prec flags ad arg-size )
   ['] parse-format execute-parsing
;
: nil$ ( -- caddr u )  s" " ;
: init  ( -- caddr 1 )  set-frame nil$ 0 0 ;    \ Test string

\ Rename these words for brevity
caseflag@ constant csf
ucflag@   constant ucf
numflag@  constant nuf
longflag@ constant lof
%fflag@   constant %ff

\ Testing conversion type specifiers
t{ init b" %d" pf -> nil$ 0 1 0 0 nuf ' %d ' %d-prefix 1 0 }t
t{ init b" %u" pf -> nil$ 0 1 0 0 nuf ' %u ' %u-prefix 1 0 }t
t{ init b" %s" pf -> nil$ 0 1 0 0 0 ' %s ' null$ 2 0 }t
t{ init b" %%" pf -> nil$ 0 1 0 0 0 ' %% ' null$ 0 0 }t
t{ init b" %x" pf -> nil$ 0 1 0 0 nuf csf or ' %x ' %x-prefix 1 0 }t
t{ init b" %c" pf -> nil$ 0 1 0 0 0 ' %c ' null$ 1 0 }t
t{ init b" %o" pf -> nil$ 0 1 0 0 nuf ' %o ' %o-prefix 1 0 }t
t{ init b" %b" pf -> nil$ 0 1 0 0 nuf ' %b ' %b-prefix 1 0 }t
t{ init b" %r" pf -> nil$ 0 1 1 0 nuf csf or ' %r ' %r-prefix 2 0 }t
t{ init b" %X" pf -> nil$ 0 1 0 0 nuf csf or ucf or ' %x ' %x-prefix 1 0 }t
t{ init b" %R" pf -> nil$ 0 1 1 0 nuf csf or ucf or ' %r ' %r-prefix 2 0 }t
fp-enabled [if]
   t{ init b" %f" pf -> nil$ 0 6 0 0 %ff ' %f ' sign-prefix 0 1float }t
   t{ init b" %e" pf -> nil$ 0 6 0 0 csf %ff or ' %e ' sign-prefix 0 1float }t
   t{ init b" %g" pf -> nil$ 0 6 0 0 csf %ff or ' %g ' sign-prefix 0 1float }t
   t{ init b" %E" pf -> nil$ 0 6 0 0 csf %ff or ucf or ' %e ' sign-prefix 0 1float }t
   t{ init b" %G" pf -> nil$ 0 6 0 0 csf %ff or ucf or ' %g ' sign-prefix 0 1float }t
[then]
t{ init b" %-s" pf -> nil$ 0 1 0 0 leftflag  ' %s ' null$ 2 0 }t   \ Testing flags
t{ init b" %0s" pf -> nil$ 0 1 0 0 0  ' %s ' null$ 2 0 }t
t{ init b" %0d" pf -> nil$ 0 1 0 0 0flag nuf or ' %d ' %d-prefix 1 0 }t
t{ init b" %+s" pf -> nil$ 0 1 0 0 +flag  ' %s ' null$ 2 0 }t
t{ init b" % s" pf -> nil$ 0 1 0 0 blflag ' %s ' null$ 2 0 }t
t{ init b" %#s" pf -> nil$ 0 1 0 0 #flag  ' %s ' null$ 2 0 }t
t{ init b" %lx" pf -> nil$ 0 1 0 0 lof csf or nuf or ' %x ' %x-prefix 2 0 }t

t{ init b" %ld" pf -> nil$ 0 1 0 0 lof nuf or ' %d ' %d-prefix 2 0 }t  \ Testing long argument size
t{ init b" %lu" pf -> nil$ 0 1 0 0 lof nuf or ' %u ' %u-prefix 2 0 }t
t{ init b" %lo" pf -> nil$ 0 1 0 0 lof nuf or ' %o ' %o-prefix 2 0 }t
t{ init b" %lx" pf -> nil$ 0 1 0 0 lof csf or nuf or ' %x ' %x-prefix 2 0 }t
t{ init b" %lX" pf -> nil$ 0 1 0 0 lof nuf or csf or ucf or ' %x ' %x-prefix 2 0 }t
t{ init b" %lb" pf -> nil$ 0 1 0 0 lof nuf or ' %b ' %b-prefix 2 0 }t
t{ init b" %lr" pf -> nil$ 0 1 1 0 lof csf or nuf or ' %r ' %r-prefix 3 0 }t
t{ init b" %lR" pf -> nil$ 0 1 1 0 lof nuf or csf or ucf or ' %r ' %r-prefix 3 0 }t

+flag@  blflag+ leftflag+ 0flag+ caseflag+
ucflag+ #flag+  longflag+ numflag+ constant most-flags
t{ init b" %+ -#0lX" pf -> nil$ 0 1 0 0 most-flags ' %x ' %x-prefix 2 0 }t

t{ init b" %123s" pf -> nil$ 123 1 0 0 0 ' %s ' null$ 2 0 }t     \ Testing width
t{ init b" %*s" pf -> nil$ -1 1 1 0 0 ' %s ' null$ 3 0 }t    \ Width on the stack

t{ init b" %.98s" pf -> nil$ 0 98 0 0 precflag ' %s ' null$ 2 0 }t \ Testing precision
t{ init b" %.s"  pf -> nil$ 0 0 0 0 precflag ' %s ' null$ 2 0 }t \ No integer for precision
t{ init b" %.*s" pf -> nil$ 0 -1 1 0 precflag ' %s ' null$ 3 0 }t \ Precision on the stack
t{ init b" %*.*s" pf -> nil$ -1 -2 2 0 precflag ' %s ' null$ 4 0 }t \ Width & precision on stack

t{ init b" %-34.56ld" pf     \ Testing all specification elements
      -> nil$ 34 56 0 0 leftflag@ precflag+ longflag+ numflag+ ' %d ' %d-prefix 2 0 }t

t{ :noname s" %1" pf ; catch -> invalid-char }t     \ Syntax error throws an exception

Testing sprintf with text using %s (simple tests)

\ In SPRINTF tests most tests are consecutively number so that, in the event of
\ a failing test, the offedning test can be easily located.

t{ b" " sprintf buf$ compare -> 0 }t                  \ Empty format string
t{ b" Hello world" sprintf buf$ compare -> 0 }t       \ Text, no conversions
t{ 50 51 b" abcd" sprintf buf$ compare -> 50 51 0 }t  \ Is stack depth correct
t{ b" bottles" s" Green %s" sprintf s" Green bottles" compare -> 0 }t
t{ b" green" s" Ten %s bottles" sprintf s" Ten green bottles" compare -> 0 }t
t{ b" Five" s" %s blue bananas" sprintf s" Five blue bananas" compare -> 0 }t
t{ b" Twobottles" drop 3 dup buf$+ s" %s red %s" sprintf
      s" Two red bottles" compare -> 0 }t
t{ 52 53 54 b" ne,othe" drop 3 3 buf$+ drop 1 4 buf$+ drop 2 6 buf$+ drop 1
      s" O%s tw%s, %sr%se!" sprintf s" One, two, three!" compare -> 52 53 54 0 }t

Testing %d and sprintf flags, width and precision

t{ 60 b" %d" sprintf s" 60" compare -> 0 }t        \ Bare %d
t{ 61 62 b" %d%d" sprintf s" 6162" compare -> 0 }t \ 2 bare %d's
t{ 63 64 b" Total: %d+%d items" sprintf
         s" Total: 63+64 items" compare -> 0 }t    \ With text
t{ 65 b" [%5d]" sprintf s" [   65]" compare -> 0 }t      \ Width only
t{ 66 b" [%.6d]" sprintf s" [000066]" compare -> 0 }t    \ Precision only
t{ 67 b" [%8.5d]" sprintf s" [   00067]" compare -> 0 }t \ Width & Precision
t{ 68 b" [%1d]" sprintf s" [68]" compare -> 0 }t         \ String length > width
t{ 69 b" [%0d]" sprintf s" [69]" compare -> 0 }t         \ No 0s
t{ 70 b" [%05d]" sprintf s" [00070]" compare -> 0 }t     \ Padded with 0's
t{ 71 b" [%07.4d]" sprintf s" [   0071]" compare -> 0 }t \ 0 flag ignored
t{ -72 b" [%d]" sprintf s" [-72]" compare -> 0 }t        \ Negative argument
t{ 73 b" [%+d]" sprintf s" [+73]" compare -> 0 }t        \ '+' needed
t{ 74 b" [% d]" sprintf s" [ 74]" compare -> 0 }t        \ Space needed
t{ 75 b" [%+ d]" sprintf s" [+75]" compare -> 0 }t       \ + overrides space
t{ -76 b" [%+ d]" sprintf s" [-76]" compare -> 0 }t      \ -ve beats + and space
t{ 77 b" [%+5d]" sprintf s" [  +77]" compare -> 0 }t     \ Width spaces and sign
t{ 78 b" [% 5d]" sprintf s" [   78]" compare -> 0 }t     \ Ditto
t{ 79 b" [%0+5d]" sprintf s" [+0079]" compare -> 0 }t    \ Width 0s and sign
t{ 80 b" [%0 6d]" sprintf s" [ 00080]" compare -> 0 }t   \ Width 0s and sign
t{ 81 b" [%+.5d]" sprintf s" [+00081]" compare -> 0 }t   \ Precision 0s
t{ 82 b" [% .4d]" sprintf s" [ 0082]" compare -> 0 }t    \ Space + precision 0s
t{ 83 b" [%+7.4d]" sprintf s" [  +0083]" compare -> 0 }t \ Width, sign, prec 0s
t{ 84 b" [% 7.4d]" sprintf s" [   0084]" compare -> 0 }t \ Ditto
t{ 85 b" [%0+6.3d]" sprintf s" [  +085]" compare -> 0 }t \ Prec beats 0 flag
t{ 86 b" [%0 6.3d]" sprintf s" [   086]" compare -> 0 }t \ Prec beats 0 flag
t{ -87 b" [%0 5.3d]" sprintf s" [ -087]" compare -> 0 }t \ Prec beats 0 flag

\ Tests 60, 65 to 87 with - flag (left justified
t{ 88 b" [%-d]" sprintf s" [88]" compare -> 0 }t          \ - flag irrelevant
t{ 89 b" [%-5d]" sprintf s" [89   ]" compare -> 0 }t      \ Width only
t{ 90 b" [%-.6d]" sprintf s" [000090]" compare -> 0 }t    \ Precision only
t{ 91 b" [%-8.5d]" sprintf s" [00091   ]" compare -> 0 }t \ Width & Precision
t{ 92 b" [%-1d]" sprintf s" [92]" compare -> 0 }t         \ String len > width
t{ 93 b" [%-0d]" sprintf s" [93]" compare -> 0 }t         \ No 0s
t{ 94 b" [%-05d]" sprintf s" [94   ]" compare -> 0 }t     \ 0 flag ignored
t{ 95 b" [%0-7.4d]" sprintf s" [0095   ]" compare -> 0 }t \ 0 flag ignored
t{ -96 b" [%-d]" sprintf s" [-96]" compare -> 0 }t        \ Negative argument
t{ 97 b" [%-+d]" sprintf s" [+97]" compare -> 0 }t        \ '+' needed
t{ 98 b" [% -d]" sprintf s" [ 98]" compare -> 0 }t        \ Space needed
t{ 99 b" [%-+ d]" sprintf s" [+99]" compare -> 0 }t       \ + overrides space
t{ -100 b" [%-+ d]" sprintf s" [-100]" compare -> 0 }t      \ -ve beats sign
t{ 101 b" [%-+5d]" sprintf s" [+101 ]" compare -> 0 }t    \ Width, spaces, sign
t{ -102 b" [%- 5d]" sprintf s" [-102 ]" compare -> 0 }t   \ Ditto
t{ 103 b" [%-0+6d]" sprintf s" [+103  ]" compare -> 0 }t   \ 0 flag ignored
t{ 104 b" [%-0 7d]" sprintf s" [ 104   ]" compare -> 0 }t  \ 0 flag ignored
t{ 105 b" [%-+.5d]" sprintf s" [+00105]" compare -> 0 }t   \ Precision 0s
t{ 106 b" [%- .4d]" sprintf s" [ 0106]" compare -> 0 }t    \ Space + prec 0s
t{ 107 b" [%-+7.4d]" sprintf s" [+0107  ]" compare -> 0 }t \ Width,sign, prec 0s
t{ 108 b" [%- 7.4d]" sprintf s" [ 0108  ]" compare -> 0 }t \ Ditto
t{ 109 b" [%-0+6.3d]" sprintf s" [+109  ]" compare -> 0 }t   \ Prec beats 0 flag
t{ 110 b" [%-0 6.3d]" sprintf s" [ 110  ]" compare -> 0 }t \ Prec beats 0 flag
t{ -111 b" [%0- 5.3d]" sprintf s" [-111 ]" compare -> 0 }t \ Prec beats 0 flag

\ Special treatment of 0 argument

t{ 112 0 b" [%d]" sprintf s" [0]" compare -> 112 0 }t    \ Default precision = 1
t{ 113 0 b" [%+d]" sprintf s" [0]" compare -> 113 0 }t   \ Signed
t{ 114 0 b" [% d]" sprintf s" [0]" compare -> 114 0 }t   \ Space for sign
t{ 115 0 b" [%+.3d]" sprintf s" [000]" compare -> 115 0 }t \ '0' padded
t{ 116 0 b" [%+.0d]" sprintf s" []" compare -> 116 0 }t \ precision = 0
t{ 117 0 b" [%+.d]" sprintf s" []" compare -> 117 0 }t  \ precision = 0
t{ 118 0 b" [% d]" sprintf s" [0]" compare -> 118 0 }t    \ no space for +ve
t{ 119 0 b" [% d]" sprintf s" [0]" compare -> 119 0 }t    \ no space for +ve
t{ 120 0 b" [% .2d]" sprintf s" [00]" compare -> 120 0 }t \ '0' padded, no space
t{ 121 0 b" [% .0d]" sprintf s" []" compare -> 121 0 }t \ '0' padded, no space
t{ 122 0 b" [% .d]" sprintf s" []" compare -> 122 0 }t \ precision = 0
t{ 123 0 b" [%05.0d]" sprintf s" [     ]" compare -> 123 0 }t
t{ 124 0 b" [%05d]" sprintf s" [00000]" compare -> 124 0 }t
t{ 125 0 b" [%#d]" sprintf s" [0]" compare -> 125 0 }t   \ Default precision=1
t{ 126 0 b" [%#+d]" sprintf s" [0]" compare -> 126 0 }t  \ Signed, no +/-sign
t{ 127 0 b" [%#+d]" sprintf s" [0]" compare -> 127 0 }t  \ Signed, no space
t{ 128 0 b" [%#+.3d]" sprintf s" [000]" compare -> 128 0 }t \ '0' padded
t{ 129 0 b" [%#+.0d]" sprintf s" []" compare -> 129 0 }t \ '0' padded, no space
t{ 130 0 b" [%#+.d]" sprintf s" []" compare -> 130 0 }t \ precision = 0
t{ 131 0 b" [%# d]" sprintf s" [0]" compare -> 131 0 }t   \ no space for +ve
t{ 132 0 b" [%# d]" sprintf s" [0]" compare -> 132 0 }t   \ no space for +ve
t{ 133 0 b" [%# .2d]" sprintf s" [00]" compare -> 133 0 }t \ 0 padded no space
t{ 134 0 b" [%# .0d]" sprintf s" []" compare -> 134 0 }t \ '0' padded, no space
t{ 135 0 b" [%# .d]" sprintf s" []" compare -> 135 0 }t \ precision = 0

\ %d with hash flag
t{ 136 b" [%#d]" sprintf s" [#136]" compare -> 0 }t   \ # no sign, width etc
t{ -137 b" [%#d]" sprintf s" [#-137]" compare -> 0 }t \ # -ve number
t{ 138 b" [%#+d]" sprintf s" [#138]" compare -> 0 }t  \ No + sign with #
t{ 139 b" [%# d]" sprintf s" [#139]" compare -> 0 }t  \ No space with #
t{ 140 b" [%#6d]" sprintf s" [  #140]" compare -> 0 }t \ width >length
t{ 141 b" [%0#7d]" sprintf s" [#000141]" compare -> 0 }t \ padded with 0
t{ -142 b" [%0#7d]" sprintf s" [#-00142]" compare -> 0 }t \ -ve, padded with 0
t{ 143 b" [%#7.4d]" sprintf s" [  #0143]" compare -> 0 }t \ precision > length
t{ 144 b" [%#07.4d]" sprintf s" [  #0144]" compare -> 0 }t \ 0 flag ignored
t{ -145 b" [%#07.4d]" sprintf s" [ #-0145]" compare -> 0 }t \ -ve
t{ 146 b" [%-#d]" sprintf s" [#146]" compare -> 0 }t   \ # no sign, width etc
t{ -147 b" [%-#d]" sprintf s" [#-147]" compare -> 0 }t \ # -ve number
t{ 148 b" [%#+-d]" sprintf s" [#148]" compare -> 0 }t  \ No + sign with #
t{ 149 b" [%-# d]" sprintf s" [#149]" compare -> 0 }t  \ No space with #
t{ 150 b" [%-#6d]" sprintf s" [#150  ]" compare -> 0 }t \ width >length
t{ 151 b" [%0-#7d]" sprintf s" [#151   ]" compare -> 0 }t \ padded with 0
t{ -152 b" [%-0#7d]" sprintf s" [#-152  ]" compare -> 0 }t \ -ve, padded with 0
t{ 153 b" [%#-7.4d]" sprintf s" [#0153  ]" compare -> 0 }t \ precision > length
t{ 154 b" [%#-07.4d]" sprintf s" [#0154  ]" compare -> 0 }t \ 0 flag ignored
t{ -155 b" [%-#07.4d]" sprintf s" [#-0155 ]" compare -> 0 }t \ -ve

\ %d with the long modifier
\ Only need a few tests as the software converts a single integer to a double
\ before any conversion.

\ 32 or 64 bit Forths? For double word tests
0 cell+ bits/au * dup 32 = constant 32bits? 64 = constant 64bits?

t{ 156 157  b" %ld" sprintf 156 157 <# #s #> compare -> 0 }t
t{ 158 -159 b" %ld" sprintf 158 -159 dabs <# #s '-' hold #> compare -> 0 }t

16bits? [if]
t{ 160 161  b" [%14ld]" sprintf s" [      10551456]" compare -> 0 }t
t{ 162 163  b" [%0+14ld]" sprintf s" [+0000010682530]" compare -> 0 }t
t{ 164 -165 b" [%#-+14ld]" sprintf s" [#-10813276    ]" compare -> 0 }t
[then]

32bits? [if]
t{ 160 161   b" [%20ld]"    sprintf s" [        691489734816]" compare -> 0 }t
t{ 162 163   b" [%0+20ld]"  sprintf s" [+0000000700079669410]" compare -> 0 }t
t{ 164 -165  b" [%#-+20ld]" sprintf s" [#-708669603676      ]" compare -> 0 }t
[then]

64bits? [if]
t{ 160 161  b" [%26ld]" sprintf s" [    2969925795867237810336]" compare -> 0 }t
t{ 162 163  b" [%0+26ld]" sprintf
            s" [+0003006819284014656913570]" compare -> 0 }t
t{ 164 -165 b" [%#-+26ld]" sprintf
            s" [#-3043712772162076016476  ]" compare -> 0 }t
[then]

\ With arguments, leading 0's for Width and precision
t{ 6 166 b" [%0*.4d]" sprintf s" [  0166]" compare -> 0 }t \ Width on stack
t{ 5 167 b" [%07.*d]" sprintf s" [  00167]" compare -> 0 }t \ Precision on stack
t{ 8 6 168 b" [%0*.*d]" sprintf s" [  000168]" compare -> 0 }t \ Both on stack
t{ 169 b" [%006.04d]" sprintf s" [  0169]" compare -> 0 }t \ 0's at start

Testing %u
t{ 180 b" [%u]" sprintf s" [180]" compare -> 0 }t
t{ 181 b" [%8u]" sprintf s" [     181]" compare -> 0 }t
t{ 182 b" [%08u]" sprintf s" [00000182]" compare -> 0 }t
t{ 183 b" [%08.5u]" sprintf s" [   00183]" compare -> 0 }t
t{ -184 b" %u" sprintf -184 0 <# #s #> compare -> 0 }t   \ Unsigned
t{ 185 b" [%+u]" sprintf s" [185]" compare -> 0 }t \ + flag ignored
t{ 186 b" [% u]" sprintf s" [186]" compare -> 0 }t \ Space flag ignored
t{ 187 b" [%#u]" sprintf s" [#187]" compare -> 0 }t   \ # flag
t{ 188 b" [%#7u]" sprintf s" [   #188]" compare -> 0 }t
t{ 189 b" [%#07u]" sprintf s" [#000189]" compare -> 0 }t
t{ 190 b" [%#07.5u]" sprintf s" [ #00190]" compare -> 0 }t
t{ -191 b" %#u" sprintf -191 0 <# #s s" #" holds #> compare -> 0 }t
t{ 192  b" [%#+ u]" sprintf s" [#192]" compare -> 0 }t

t{ 193 0 b" [%u]" sprintf s" [0]" compare -> 193 0 }t
t{ 194 0 b" [%05.3u]" sprintf s" [  000]" compare -> 194 0 }t
t{ 195 0 b" [%0.0u]" sprintf s" []" compare -> 195 0 }t
t{ 196 0 b" [%05.0u]" sprintf s" [     ]" compare -> 196 0 }t
t{ 197 0 b" [%#u]" sprintf s" [#0]" compare -> 197 0 }t
t{ 198 0 b" [%#05.3u]" sprintf s" [ #000]" compare -> 198 0 }t
t{ 199 0 b" [%#0.0u]" sprintf s" []" compare -> 199 0 }t
t{ 200 0 b" [%#05.0u]" sprintf s" [     ]" compare -> 200 0 }t

: ud>$  ( caddr u ud caddr2 u2 -- caddr3 u3 )
   2>r 2swap <# ']' hold holds #s 2r> holds '[' hold #>
;
t{ 201  202 b" %lu" sprintf 201  202 <# #s #> compare -> 0 }t
t{ 203 -204 b" %lu" sprintf 203 -204 <# #s #> compare -> 0 }t

t{ 205 b" [%-u]" sprintf s" [205]" compare -> 0 }t
t{ 206 b" [%-8u]" sprintf s" [206     ]" compare -> 0 }t
t{ 207 b" [%-08u]" sprintf s" [207     ]" compare -> 0 }t
t{ 208 b" [%-08.5u]" sprintf s" [00208   ]" compare -> 0 }t
t{ -209 b" [%-u]" sprintf nil$ -209 0 nil$ ud>$ compare -> 0 }t   \ Unsigned
t{ 210 b" [%-+u]" sprintf s" [210]" compare -> 0 }t \ + flag ignored
t{ 211 b" [%- u]" sprintf s" [211]" compare -> 0 }t \ Space flag ignored
t{ 212 b" [%#-u]" sprintf s" [#212]" compare -> 0 }t   \ # flag
t{ 213 b" [%#-7u]" sprintf s" [#213   ]" compare -> 0 }t
t{ 214 b" [%#-07u]" sprintf s" [#214   ]" compare -> 0 }t
t{ 215 b" [%-#07.5u]" sprintf s" [#00215 ]" compare -> 0 }t
t{ -216 b" [%-#u]" sprintf nil$ -216 0 s" #" ud>$ compare -> 0 }t
t{ 217  b" [%-#+ u]" sprintf s" [#217]" compare -> 0 }t

t{ 218 0 b" [%-u]" sprintf s" [0]" compare -> 218 0 }t
t{ 219 0 b" [%-05.3u]" sprintf s" [000  ]" compare -> 219 0 }t
t{ 220 0 b" [%-0.0u]" sprintf s" []" compare -> 220 0 }t
t{ 221 0 b" [%-05.0u]" sprintf s" [     ]" compare -> 221 0 }t
t{ 222 0 b" [%#-u]" sprintf s" [#0]" compare -> 222 0 }t
t{ 223 0 b" [%#-05.3u]" sprintf s" [#000 ]" compare -> 223 0 }t
t{ 224 0 b" [%#-0.0u]" sprintf s" []" compare -> 224 0 }t
t{ 225 0 b" [%#-05.0u]" sprintf s" [     ]" compare -> 225 0 }t

Testing %x and %X
\ As %x uses the same code as %u we only need simple tests

t{ 240 $abcd b" [%x]" sprintf s" [abcd]" compare -> 240 0 }t
t{ 241 $ef01 b" [%x]" sprintf s" [ef01]" compare -> 241 0 }t
t{ 242 $ABCD b" [%x]" sprintf s" [abcd]" compare -> 242 0 }t
t{ 243 $EF34 b" [%x]" sprintf s" [ef34]" compare -> 243 0 }t
t{ 244 $-abcd b" [%x]" sprintf
       nil$ $-abcd 0 nil$ hex ud>$ decimal >lower compare -> 244 0 }t
t{ 245 $aBCd b" [%0+ 8x]" sprintf s" [0000abcd]" compare -> 245 0 }t
t{ 246 $eF56 b" [%+0 8.5x]" sprintf s" [   0ef56]" compare -> 246 0 }t
t{ 247 $bcd  b" [%#8.5x]" sprintf s" [  $00bcd]" compare -> 247 0 }t
t{ $248 b" [%-0+ 8.3x]" sprintf s" [248     ]" compare -> 0 }t
t{ $249 b" [%-#+0 8.5x]" sprintf s" [$00249  ]" compare -> 0 }t

t{ 250 $abcd b" [%X]" sprintf s" [ABCD]" compare -> 250 0 }t
t{ 251 $ef78 b" [%X]" sprintf s" [EF78]" compare -> 251 0 }t
t{ 252 $-abcd b" [%X]" sprintf
       nil$ $-abcd 0 nil$ hex ud>$ decimal >upper compare -> 252 0 }t
t{ 253 $fedc b" [%#-+ 09.6X]" sprintf s" [$00FEDC  ]" compare -> 253 0 }t
t{ 254 $FAB $-DCE b" [%lx]" sprintf
       nil$ $fab $-dce nil$ hex ud>$ decimal >lower compare -> 254 0 }t

Testing %o  \ Only simple tests needed
t{ 260 1023 b" [%o]" sprintf s" [1777]" compare -> 260 0 }t
t{ 261 1024 b" [%#o]" sprintf s" [02000]" compare -> 261 0 }t  \ Prefix of '0'
t{ 262 127  b" [%#+ 7.5o]" sprintf s" [  00177]" compare -> 262 0 }t \ No prefix
t{ 263 b" [%#-7.5o]" sprintf s" [00407  ]" compare -> 0 }t \ No prefix
t{ 264 -265 b" [%lo]" sprintf
       nil$ 264 -265 nil$ #8 base ! ud>$ decimal compare -> 0 }t
t{ 266 0 b" [%#o]" sprintf s" [0]" compare -> 266 0 }t   \ 0 argument, no prefix
t{ 267 0 0 b" [%#lo]" sprintf s" [0]" compare -> 267 0 }t


Testing %b  \ Only simple tests needed
t{ 270 b" [%b]" sprintf s" [100001110]" compare -> 0 }t
t{ 271 b" [%#b]" sprintf s" [%100001111]" compare -> 0 }t
t{ 272 b" [%#15.12b]" sprintf s" [  %000100010000]" compare -> 0 }t
t{ 273 b" [%-#15.11b]" sprintf s" [%00100010001   ]" compare -> 0 }t
t{ 13 11 274 b" [%#*.*b]" sprintf s" [ %00100010010]" compare -> 0 }t

Testing %r and %R

t{ 36 281  b" [%r]" sprintf s" [7t]" compare -> 0 }t
t{ 282 23 $FFFF b" [%R]" sprintf s" [58K8]" compare -> 282 0 }t
t{ 7 17 283 b" [%#*.3r]" sprintf s" [    0gb]" compare -> 0 }t
t{ 5 17 284 b" [%-7.*R]" sprintf s" [000GC  ]" compare -> 0 }t
t{ 9 4 17 285 b" [%*.*r]" sprintf s" [     00gd]" compare -> 0 }t
t{ 29 286 287 b" [%lr]" sprintf
       nil$ 286 287 nil$ #29 base ! ud>$ >lower decimal compare -> 0 }t
t{ 17 -288 b" [%+.5R]" sprintf s" [-000GG]" compare -> 0 }t
t{ 17  289 b" [% r]" sprintf s" [ 100]" compare -> 0 }t

\ %r with bases having a #flag prefix
t{ 10 290 b" [%#r]" sprintf s" [#290]" compare -> 0 }t
t{ 10 -291 b" [%#r]" sprintf s" [#-291]" compare -> 0 }t
t{ 292 10 0 b" [%#r]" sprintf s" [0]" compare -> 292 0 }t

t{ 16 293 b" [%#r]" sprintf s" [$125]" compare -> 0 }t
t{ 16 -294 b" [%#r]" sprintf s" [$-126]" compare -> 0 }t
t{ 295 16 0 b" [%#r]" sprintf s" [0]" compare -> 295 0 }t

t{ 8 296 b" [%#r]" sprintf s" [0450]" compare -> 0 }t
t{ 8 -297 b" [%#r]" sprintf s" [-0451]" compare -> 0 }t
t{ 298 8 0 b" [%#r]" sprintf s" [0]" compare -> 298 0 }t

t{ 2 299 b" [%#r]" sprintf s" [%100101011]" compare -> 0 }t
t{ 2 -300 b" [%#r]" sprintf s" [%-100101100]" compare -> 0 }t
t{ 301 2 0 b" [%#r]" sprintf s" [0]" compare -> 301 0 }t

Testing %c %%
t{ 350 'A' b" [%c]" sprintf s" [A]" compare -> 350 0 }t
t{ 351 bl  b" [%c]" sprintf s" [ ]" compare -> 351 0 }t
t{ 352 '~' b" [%c]" sprintf s" [~]" compare -> 352 0 }t
t{ 353 'z' b" [%5c]"  sprintf s" [    z]" compare -> 353 0 }t
t{ 354 'z' b" [%-5c]" sprintf s" [z    ]" compare -> 354 0 }t
t{ 355 '-' b" [%.4c]" sprintf s" [----]" compare -> 355 0 }t
t{ 356 '*' b" [%.0c]" sprintf s" []" compare -> 356 0 }t
t{ 357 '@' b" [%05.3c]"  sprintf s" [  @@@]" compare -> 357 0 }t \ No 0's
t{ 358 '&' b" [%-05.3c]" sprintf s" [&&&  ]" compare -> 358 0 }t \ No 0's
t{ 359 '7' b" [%+ lc]" sprintf s" [7]" compare -> 359 0 }t  \ Ignore flags & 'l'
t{ 360 'x' b" [%#c]" sprintf s" ['x']" compare -> 360 0 }t \ Output Forth char
t{ 361 'K' b" [%#.4c]" sprintf s" ['K']" compare -> 361 0 }t \ # flag beats prec
t{ 362 b" [%%]" sprintf s" [%]" compare -> 362 0 }t
t{ 363 b" [%#0-+ l%]" sprintf s" [%]" compare -> 363 0 }t \ Ignore flags & 'l'
t{ 364 b" [%05.3%]" sprintf s" [%]" compare -> 364 0 }t \ Ignore width & prec
t{ 365 7 3 b" [%0*.*%]" sprintf s" [%]" compare -> 365 0 }t \ Ignore width & prec
t{ 366 9 4 '5' b" [%u %*.*%age: %c]" sprintf s" [366 %age: 5]" compare -> 0 }t
 
Testing %s (more tests)
t{ 380 b" abcde" s" [%7s]" sprintf s" [  abcde]" compare -> 380 0 }t
t{ 381 b" fgh" s" [%-6s]" sprintf s" [fgh   ]" compare -> 381 0 }t
t{ 382 b" ijkl" s" [%#0+ 7s]" sprintf s" [   ijkl]" compare -> 382 0 }t
t{ 383 b" mnopq" s" [%7.6s]" sprintf s" [  mnopq]" compare -> 383 0 }t
t{ 384 b" rst" s" [%7.0s]" sprintf s" [       ]" compare -> 384 0 }t
t{ 385 b" uvwx" s" [%4.s]" sprintf s" [    ]" compare -> 385 0 }t
t{ 386 b" yz" s" [%.s]" sprintf s" []" compare -> 386 0 }t

fp-enabled [if]
Testing %e and %E

t{ 400 1.234567e89 b" [%e]" sprintf s" [1.234567e+89]" compare -> 400 0 }t
t{ 401 1.234567e8 b" [%e]" sprintf s" [1.234567e+08]" compare -> 401 0 }t
t{ 402 1.234567e0 b" [%e]" sprintf s" [1.234567e+00]" compare -> 402 0 }t
t{ 403 2.345678e-89 b" [%E]" sprintf s" [2.345678E-89]" compare -> 403 0 }t
t{ 404 3.456789e-89 b" [%+e]" sprintf s" [+3.456789e-89]" compare -> 404 0 }t
t{ 405 4.567890e89 b" [% e]" sprintf s" [ 4.567890e+89]" compare -> 405 0 }t
t{ 406 -5.678901e89 b" [%e]" sprintf s" [-5.678901e+89]" compare -> 406 0 }t
t{ 407 6.789012e89 b" [%+ e]" sprintf s" [+6.789012e+89]" compare -> 407 0 }t
t{ 408 -7.890123e89 b" [%+ e]" sprintf s" [-7.890123e+89]" compare -> 408 0 }t
t{ 409 8.901234e89 b" [%15e]" sprintf s" [   8.901234e+89]" compare -> 409 0 }t
t{ 410 9.012345e89 b" [%016e]" sprintf s" [00009.012345e+89]" compare -> 410 0 }t
t{ 411 0.234567e89 b" [%-14e]" sprintf s" [2.345670e+88  ]" compare -> 411 0 }t
t{ 412 1.234567e89 b" [%0-14e]" sprintf s" [1.234567e+89  ]" compare -> 412 0 }t
t{ 413 1.234567e89 b" [%#e]" sprintf s" [1.234567e+89]" compare -> 413 0 }t
t{ 414 5e0 b" [%e]" sprintf s" [5.000000e+00]" compare -> 414 0 }t
t{ 415 5e0 b" [%.0e]" sprintf s" [5e+00]" compare -> 415 0 }t
t{ 416 5e0 b" [%#.0e]" sprintf s" [5.e+00]" compare -> 416 0 }t
t{ 417 1.234567e0 b" [%.5e]" sprintf s" [1.23457e+00]" compare -> 417 0 }t
t{ 418 1.234567e1 b" [%.3e]" sprintf s" [1.235e+01]" compare -> 418 0 }t
t{ 419 1.234567e2 b" [%.e]" sprintf s" [1e+02]" compare -> 419 0 }t
t{ 420 1.5e5 b" [%.e]" sprintf s" [2e+05]" compare -> 420 0 }t
t{ 421 9.9999994e9 b" [%e]" sprintf s" [9.999999e+09]" compare -> 421 0 }t
t{ 422 9.9999995e9 b" [%e]" sprintf s" [1.000000e+10]" compare -> 422 0 }t
t{ 423 9.9e5 b" [%.e]" sprintf s" [1e+06]" compare -> 423 0 }t
t{ 424 -9.8999e-100 b" [%012.1e]" sprintf s" [-0009.9e-100]" compare -> 424 0 }t
t{ 425 0e1 b" [%e]" sprintf s" [0.000000e+00]" compare -> 425 0 }t

\ Testing %e with a large run of zeroes due to large precision
: check1.25e100%e  ( caddr u -- f )  \ True to pass
   2dup 2>r 157 = swap       ( -- f caddr )  \ Check overall length
   4 s" 1.25" compare 0= and                 \ check initial digits
   -1 2r@ 4 /string 5 - over + swap
   do i c@ '0' = and loop and                \ Check zeroes
   2r> 152 /string s" e+100" compare 0= and
;
\ This should give "1.25...(148 zeroes)...e+100"
t{ 426 1.25e100 b" %.150e" sprintf check1.25e100%e -> 426 -1 }t

Testing %f

t{ 500 1.234567e8  b" [%f]" sprintf s" [123456700.000000]" compare -> 500 0 }t
t{ 501 2.345678e6  b" [%f]" sprintf s" [2345678.000000]" compare -> 501 0 }t
t{ 502 3.456789e5  b" [%f]" sprintf s" [345678.900000]" compare -> 502 0 }t
t{ 503 4.567891e0  b" [%f]" sprintf s" [4.567891]" compare -> 503 0 }t
t{ 504 5.678912e-1 b" [%f]" sprintf s" [0.567891]" compare -> 504 0 }t
t{ 505 6.789123e-4 b" [%f]" sprintf s" [0.000679]" compare -> 505 0 }t
t{ 506 7.891234e-6 b" [%f]" sprintf s" [0.000008]" compare -> 506 0 }t
t{ 507 5.912345e-7 b" [%f]" sprintf s" [0.000001]" compare -> 507 0 }t
t{ 508 4.912345e-7 b" [%f]" sprintf s" [0.000000]" compare -> 508 0 }t
t{ 509 5.912345e-8 b" [%f]" sprintf s" [0.000000]" compare -> 509 0 }t
t{ 510 -1.234e0 b" [%+f]" sprintf s" [-1.234000]" compare -> 510 0 }t
t{ 511 1e0 b" [%+f]" sprintf s" [+1.000000]" compare -> 511 0 }t
t{ 512 2e0 b" [% f]" sprintf s" [ 2.000000]" compare -> 512 0 }t
t{ 513 -3e0 b" [%+ f]" sprintf s" [-3.000000]" compare -> 513 0 }t
t{ 514 4e0 b" [%10f]" sprintf s" [  4.000000]" compare -> 514 0 }t
t{ 515 5e0 b" [%010f]" sprintf s" [005.000000]" compare -> 515 0 }t
t{ 516 6e0 b" [%-10f]" sprintf s" [6.000000  ]" compare -> 516 0 }t
t{ 517 7e0 b" [%-+10f]" sprintf s" [+7.000000 ]" compare -> 517 0 }t
t{ 518 0.89123e0 b" [%.3f]" sprintf s" [0.891]" compare -> 518 0 }t
t{ 519 0.89953e0 b" [%.3f]" sprintf s" [0.900]" compare -> 519 0 }t
t{ 520 0.9123e0 b" [%.1f]" sprintf s" [0.9]" compare -> 520 0 }t
t{ 521 0.9623e0 b" [%.1f]" sprintf s" [1.0]" compare -> 521 0 }t
t{ 522 0.9623e0 b" [%.0f]" sprintf s" [1]" compare -> 522 0 }t
t{ 523 0.9623e0 b" [%#.0f]" sprintf s" [1.]" compare -> 523 0 }t
t{ 524 0.9623e10 b" [%.0f]" sprintf s" [9623000000]" compare -> 524 0 }t
t{ 525 0.9623e10 b" [%#.0f]" sprintf s" [9623000000.]" compare -> 525 0 }t
t{ 526 0e1 b" [%f]" sprintf s" [0.000000]" compare -> 526 0 }t
t{ 527 0e1 b" [%.2f]" sprintf s" [0.00]" compare -> 527 0 }t
t{ 528 0e1 b" [%.f]" sprintf s" [0]" compare -> 528 0 }t
t{ 529 0e1 b" [%#.f]" sprintf s" [0.]" compare -> 529 0 }t
t{ 530 0e1 b" [%+.1f]" sprintf s" [+0.0]" compare -> 530 0 }t
t{ 531 -0e1 b" [%.1f]" sprintf s" [-0.0]" compare -> 531 0 }t

Testing runs of zeros due to large exponents or precision
t{ 532 0.123456789012345e40 b" %f" sprintf
   s" 1234567890123450000000000000000000000000.000000" compare -> 532 0 }t
t{ 533 0.123456789012345e15 b" %f" sprintf
                            s" 123456789012345.000000" compare -> 533 0 }t
t{ 534 0.123456789012345e15 b" %.0f" sprintf
                                   s" 123456789012345" compare -> 534 0 }t
t{ 535 0.123456789012345e13 b" %.20f" sprintf
                s" 1234567890123.45000000000000000000" compare -> 535 0 }t
t{ 536 0.123456789012345e9 b" %f" sprintf
                                  s" 123456789.012345" compare -> 536 0 }t
t{ 537 0.123456789012345e2 b" %f" sprintf
                                         s" 12.345679" compare -> 537 0 }t
t{ 538 0.123456789012345e0 b" %.18f" sprintf
                              s" 0.123456789012345000" compare -> 538 0 }t
t{ 539 0.123456789012345e0 b" %.15f" sprintf
                                 s" 0.123456789012345" compare -> 539 0 }t
t{ 540 0.123456789012345e0 b" %.12f" sprintf
                                    s" 0.123456789012" compare -> 540 0 }t
t{ 541 0.123456789012345e-5 b" %.8f" sprintf
                                        s" 0.00000123" compare -> 541 0 }t
t{ 542 0.123456789012345e-5 b" %.20f" sprintf
                            s" 0.00000123456789012345" compare -> 542 0 }t
t{ 543 0.123456789012345e-5 b" %.26f" sprintf
                      s" 0.00000123456789012345000000" compare -> 543 0 }t

Testing %g and %G

\ Test use of %e or %f conversions by varying exponent, precision=6 (default)
t{ 600 1.2345678e-5 b" [%g]" sprintf s" [1.23457e-05]" compare -> 600 0 }t
t{ 601 1.2345678e-4 b" [%g]" sprintf s" [0.000123457]" compare -> 601 0 }t
t{ 602 1.2345678e-3 b" [%g]" sprintf s" [0.00123457]" compare -> 602 0 }t
t{ 603 1.2345678e-2 b" [%g]" sprintf s" [0.0123457]" compare -> 603 0 }t
t{ 604 1.2345678e-1 b" [%g]" sprintf s" [0.123457]" compare -> 604 0 }t
t{ 605 1.2345678e0  b" [%g]" sprintf s" [1.23457]" compare -> 605 0 }t
t{ 606 1.2345678e1  b" [%g]" sprintf s" [12.3457]" compare -> 606 0 }t
t{ 607 1.2345678e2  b" [%g]" sprintf s" [123.457]" compare -> 607 0 }t
t{ 608 1.2345678e3  b" [%g]" sprintf s" [1234.57]" compare -> 608 0 }t
t{ 609 1.2345678e4  b" [%g]" sprintf s" [12345.7]" compare -> 609 0 }t
t{ 610 1.2345678e5  b" [%g]" sprintf s" [123457]" compare -> 610 0 }t
t{ 611 1.2345678e6  b" [%g]" sprintf s" [1.23457e+06]" compare -> 611 0 }t
t{ 612 1.2345678e7  b" [%g]" sprintf s" [1.23457e+07]" compare -> 612 0 }t
t{ 613 1.2345678e8  b" [%g]" sprintf s" [1.23457e+08]" compare -> 613 0 }t

\ Test use of %e or %f conversions by varying precision
\ Specified precision <= 0 treated as precision = 1
t{ 614 -3 9.87654321e7 b" [%.*g]" sprintf s" [1e+08]" compare -> 614 0 }t
t{ 615 9.87654321e7 b" [%.0g]" sprintf s" [1e+08]" compare -> 615 0 }t
t{ 616 9.87654321e7 b" [%.1g]" sprintf s" [1e+08]" compare -> 616 0 }t
t{ 617 9.87654321e7 b" [%.2g]" sprintf s" [9.9e+07]" compare -> 617 0 }t
t{ 618 9.87654321e7 b" [%.3g]" sprintf s" [9.88e+07]" compare -> 618 0 }t
t{ 619 9.87654321e7 b" [%.4g]" sprintf s" [9.877e+07]" compare -> 619 0 }t
t{ 620 9.87654321e7 b" [%.5g]" sprintf s" [9.8765e+07]" compare -> 620 0 }t
t{ 621 9.87654321e7 b" [%.6g]" sprintf s" [9.87654e+07]" compare -> 621 0 }t
t{ 622 9.87654321e7 b" [%.7g]" sprintf s" [9.876543e+07]" compare -> 622 0 }t
t{ 623 9.87654321e7 b" [%.8g]" sprintf s" [98765432]" compare -> 623 0 }t
t{ 624 9.87654321e7 b" [%.9g]" sprintf s" [98765432.1]" compare -> 624 0 }t

\ Test removal of trailing zeroes
t{ 625 1.2e-5       b" [%g]" sprintf s" [1.2e-05]" compare -> 625 0 }t
t{ 626 1.2399999e-5 b" [%g]" sprintf s" [1.24e-05]" compare -> 626 0 }t

\ Test display of trailing zeroes
t{ 627 1.2e-5 b" [%#g]" sprintf s" [1.20000e-05]" compare -> 627 0 }t

\ Test display of decimal point without following digits
t{ 628 1e5 b" [%#g]" sprintf s" [100000.]" compare -> 628 0 }t

\ Test other flags and width
t{ 629 2.345e-5 b" [%+g]" sprintf s" [+2.345e-05]" compare -> 629 0 }t
t{ 630 2.345e-5 b" [% g]" sprintf s" [ 2.345e-05]" compare -> 630 0 }t
t{ 631 -2.345e-5 b" [%13g]" sprintf s" [   -2.345e-05]" compare -> 631 0 }t
t{ 632 2.345e-5 b" [%0+14g]" sprintf s" [+00002.345e-05]" compare -> 632 0 }t
t{ 633 2.345e-5 b" [%-12g]" sprintf s" [2.345e-05   ]" compare -> 633 0 }t
t{ 634 2.345e-5 b" [% -#14g]" sprintf s" [ 2.34500e-05  ]" compare -> 634 0 }t

Testing infinities, NaNs and BAD
\ Creates an 'out of range' FP number , by generating r^n
: fpinf  ( f -- ) ( r -- r2 ) \ f true if negative required
   begin
      fdup sprf-pad 4 represent
   while
      fabs 2drop fdup f* dup if fnegate then
   repeat
   2drop drop
;

[undefined] SwiftForth [if]
t{ 650 1.5e0 fasin b" [%g]" sprintf s" [nan]" compare -> 650 0 }t
t{ 651 2e5  0 fpinf b" [%e]" sprintf s" [inf]" compare -> 651 0 }t
t{ 652 2e5 -1 fpinf b" [%g]" sprintf s" [-inf]" compare -> 652 0 }t
t{ 653 1.5e0 fasin b" [%E]" sprintf s" [NAN]" compare -> 653 0 }t
t{ 654 2e5  0 fpinf b" [%G]" sprintf s" [INF]" compare -> 654 0 }t
t{ 655 2e5 -1 fpinf b" [%E]" sprintf s" [-INF]" compare -> 655 0 }t
t{ 656 2e5 -1 fpinf b" [%7g]" sprintf s" [   -inf]" compare -> 656 0 }t
t{ 657 2e5 0 fpinf b" [%-7g]" sprintf s" [inf    ]" compare -> 657 0 }t
t{ 658 2e5 0 fpinf b" [%- 7g]" sprintf s" [inf    ]" compare -> 658 0 }t
t{ 659 2e5 0 fpinf b" [%#0+ 9.7g]" sprintf s" [      inf]" compare -> 659 0 }t
[then]

\ Test large run of zeroes with %g
t{ 660 0.123456e23 b" %#.33g" sprintf 
                 s" 12345600000000000000000.0000000000" compare -> 660 0 }t
: check1.25e143%g  ( caddr u -- f )  \ True to pass
   2dup 2>r 149 = swap       ( -- f caddr )  \ Check overall length
   4 s" 1.25" compare 0= and                 \ check initial digits
   -1 2r@ 4 /string 5 - over + swap
   do i c@ '0' = and loop and                \ Check zeroes
   2r> 144 /string s" e+143" compare 0= and
;
\ This should give "1.25...(140 zeroes)...e+143"
t{ 661 1.25e143 b" %#.143g" sprintf check1.25e143%g -> 661 -1 }t

\ Test a 'BAD' return from REPRESENT by calling the appropriate internal word
pad max-precision bl fill
t{ 662 pad 1 invalid-number -> 662 #6589 }t

Testing multiple floating point arguments with/out other conversions

clear-fp-stack
t{ 700 4.56e0 5.67e1 6.78e2 b" %e %.1E" sprintf s" 5.670000e+01 6.8E+02" compare
\ cr ." Fdepth: " fdepth . ." , FP tos: " fdup fs. ." , fp-depth: " fp-depth @ . cr
            4.56e0 f- f0= fdepth -> 700 0 true 0 }t
clear-fp-stack
t{ 701 1 1.23e0 '2' 2.34e0 s" (3) " 3.45e0 b" (%d) %.3e, (%c) %.4f, %s%.5g" sprintf
               s" (1) 1.230e+00, (2) 2.3400, (3) 3.45" compare -> 701 0 }t
[then]
Testing errors

cr cr 
fp-enabled [if]
   .( Six error reports should be displayed:)
[else]
   .( Five error reports should be displayed:)
[then] cr
.( ------)
t{ 750 :noname s" This specification %&d is bad" sprintf ; catch -> 750 -1 }t
.( ------)
t{ 751 :noname s" Not enough %d %d arguments" sprintf ; catch -> 751 -1 }t
.( ------)
max-conv-width constant mcw sprbuf-size 10 + to max-conv-width
t{ 752 :noname sprbuf-size 1+ 0 s" %*.0u" sprintf ; catch -> 752 -1 }t
mcw to max-conv-width
.( ------)
variable sprbuf-ad sprbuf$ drop sprbuf-ad ! 0 to sprbuf
t{ 753 b" Buffer not set" sprintf -> 753 }t
sprbuf-ad @ to sprbuf
.( ------)
fp-enabled [if]
   clear-fp-stack
   t{ 754 :noname s" Not enough %e FP arguments" sprintf ; catch -> 754 -1 }t
   .( ------)
   max-fp-args constant mfpa 2 to max-fp-args   \ To induce an error
   t{ 755 :noname s" Too many fp formats %f %e %g" sprintf ; catch -> 755 -1 }t
   mfpa to max-fp-args     \ Restore the default value
   .( ------)
[else]
   t{ 756 :noname s" FP conversion %#+10f - no FP" sprintf ; catch -> 756 -1 }t
   .( ------)
[then]

cr .( End of tests )
cr cr .( -----[ Report ]-------)
#errors @ [if] cr .( *** Errors ***) [then]
cr .stack
cr .fpstack
cr .( Number of tests:)  #tests  @ 6 .r
cr .( Number of errors:) #errors @ 5 .r
cr .( ----------------------)

previous
cr cr

\ ---[ End of file ]------------------------------------------------------------


by GerryJackson

avatar of GerryJackson

Versions

1.0.2, 1.0.1, 1.0.0

Download current as zip

Tags

forth-2012, tools

Dependencies

None

Dependents

None