diff options
Diffstat (limited to 'forth')
| -rw-r--r-- | forth/core.fth | 16 | ||||
| -rw-r--r-- | forth/test/core.fr | 71 |
2 files changed, 52 insertions, 35 deletions
diff --git a/forth/core.fth b/forth/core.fth index bbaa67d..f16224a 100644 --- a/forth/core.fth +++ b/forth/core.fth @@ -2,6 +2,7 @@ : s>d 1 m* ; : / >r s>d r> _/ ; : % >r s>d r> _% ; +: um* 0 swap 0 _uma ; : cell+ 2 + ; : cells 2 * ; @@ -201,3 +202,18 @@ : evaluate _source @ >r _sourceu @ >r >in @ >r 0 >in ! _sourceu ! _source ! _ev r> >in ! r> _sourceu ! r> _source ! ; + +: _isdigit ( ch -- bch ) + dup [char] 0 over <= swap [char] 0 base @ 10 min 1- + <= and + if drop [char] 0 exit then + base @ 11 < if drop 0 exit then + base @ 36 min 10 - >r + dup [char] a over <= swap [char] a r@ + < and + if r> 2drop [char] a 10 - exit then + [char] A over <= swap [char] A r> + < and + if [char] A 10 - else 0 then ; +: >number begin dup 0 > + dup if drop over c@ _isdigit then while + >r dup c@ swap >r base @ swap + dup _isdigit - _uma + r> char+ r> 1- repeat ; diff --git a/forth/test/core.fr b/forth/test/core.fr index 42fff25..f326432 100644 --- a/forth/test/core.fr +++ b/forth/test/core.fr @@ -820,6 +820,7 @@ T{ GS4 123 456 \ \ ------------------------------------------------------------------------ \ TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL +." TESTING BASE >NUMBER HEX DEMICAL" CR \ \ : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. \ >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH @@ -845,12 +846,12 @@ T{ GS4 123 456 \ \ : GP4 <# 1 0 #S #> S" 1" S= ; \ T{ GP4 -> <TRUE> }T -\ -\ 24 CONSTANT MAX-BASE \ BASE 2 .. 36 -\ : COUNT-BITS -\ 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; -\ COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD -\ + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + \ : GP5 \ BASE @ <TRUE> \ MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE @@ -885,30 +886,30 @@ T{ GS4 123 456 \ R> BASE ! ; \ \ T{ GP7 -> <TRUE> }T -\ -\ \ >NUMBER TESTS -\ CREATE GN-BUF 0 C, -\ : GN-STRING GN-BUF 1 ; -\ : GN-CONSUMED GN-BUF CHAR+ 0 ; -\ : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; -\ -\ T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T -\ T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T -\ T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T -\ T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE -\ T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T -\ T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T -\ -\ : >NUMBER-BASED -\ BASE @ >R BASE ! >NUMBER R> BASE ! ; -\ -\ T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T -\ T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T -\ T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T -\ T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T -\ T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T -\ T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T -\ + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + \ : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. \ BASE @ >R BASE ! \ <# #S #> @@ -920,11 +921,11 @@ T{ GS4 123 456 \ T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T \ T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T \ T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T -\ -\ : GN2 \ ( -- 16 10 ) -\ BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; -\ T{ GN2 -> 10 A }T -\ + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + \ ------------------------------------------------------------------------ ." TESTING FILL MOVE" CR |