>number

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