\ 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 ]------------------------------------------------------------
