implement pictured numeric output

diff --git a/README.md b/README.md
index 434136ed25d5fa2a26bdcd7a9196836a917e6fab..eca6085740c9c4ec97422cbb484f34015ddc8bb0 100644 (file)
--- a/README.md
+++ b/README.md
@@ -10,10 +10,7 @@ System-specific functionality is obtained through a `sys` Forth word. This word
 
 ## Forth compatibility
 
-Alee implements a large majority of the "core" and "core extension" [word-sets](https://forth-standard.org/standard/core). Implementation is tracked in `compat.txt` with missing words listed below. Fundamental words are hard-coded into Alee while the rest of the implementation is found in `forth/core.fth` and `forth/core-ext.fth`. Running Alee without these implementation files will leave you with a very minimal word-set. These files may be compiled into the Alee binary by building the `standalone` target.
-
-**Missing** core features:  
-* Pictured numeric output conversion (e.g. `<# #>`)
+Alee implements the entire "core" and majority of the "core extension" [word-sets](https://forth-standard.org/standard/core). Implementation is tracked in `compat.txt` with missing words listed below. Fundamental words are hard-coded into Alee while the rest of the implementation is found in `forth/core.fth` and `forth/core-ext.fth`. Running Alee without these implementation files will leave you with a very minimal word-set. These files may be compiled into the Alee binary by building the `standalone` target.
 
 **Missing** core extensions:  
 ```

diff --git a/compat.txt b/compat.txt
index 49d39cf8f629b00c3357e13a49756588f2961ff9..3ea8630ecdafbf47b94f87c33e08e07cee3ab6c9 100644 (file)
--- a/compat.txt
+++ b/compat.txt
@@ -1,15 +1,15 @@
 6.1 Core words
 
 yes 6.1.0010 !
-    6.1.0030 #
-    6.1.0040 #>
-    6.1.0050 #S
+yes 6.1.0030 #
+yes 6.1.0040 #>
+yes 6.1.0050 #S
 yes 6.1.0070 '
 yes 6.1.0080 (
 yes 6.1.0090 *
 yes 6.1.0100 */
 yes 6.1.0110 */MOD
-yes 6.1.0120
+yes 6.1.0120 +
 yes 6.1.0130 +!
 yes 6.1.0140 +LOOP
 yes 6.1.0150 ,
@@ -33,7 +33,7 @@ yes 6.1.0430 2SWAP
 yes 6.1.0450 :
 yes 6.1.0460 ;
 yes 6.1.0480 <
-    6.1.0490 <#
+yes 6.1.0490 <#
 yes 6.1.0530 =
 yes 6.1.0540 >
 yes 6.1.0550 >BODY
@@ -81,7 +81,7 @@ yes 6.1.1540 FILL
 yes 6.1.1550 FIND
 yes 6.1.1561 FM/MOD
 yes 6.1.1650 HERE
-    6.1.1670 HOLD
+yes 6.1.1670 HOLD
 yes 6.1.1680 I
 yes 6.1.1700 IF
 yes 6.1.1710 IMMEDIATE (as "imm")
@@ -110,7 +110,7 @@ yes 6.1.2160 ROT
 yes 6.1.2162 RSHIFT
 yes 6.1.2165 S"
 yes 6.1.2170 S>D
-    6.1.2210 SIGN
+yes 6.1.2210 SIGN
 yes 6.1.2214 SM/REM
 yes 6.1.2216 SOURCE
 yes 6.1.2220 SPACE

diff --git a/forth/core.fth b/forth/core.fth
index f16224ac48bcc84c698c42147a2d168a901a617e..ec4bcb59e535b2e1bdf547efa09e351ea7be3604 100644 (file)
--- a/forth/core.fth
+++ b/forth/core.fth
@@ -217,3 +217,14 @@
            >r dup c@ swap >r base @ swap
            dup _isdigit - _uma
            r> char+ r> 1- repeat ;
+
+: <#       40 here c! ;
+: #>       2drop here dup c@ + 40 here c@ - ;
+: hold     -1 here +! here dup c@ + c! ;
+: #        base @
+           >r 0 i um/mod r> swap >r um/mod r>
+           rot 9 over <
+           if 7 + then 48 + hold ;
+: #s       begin # 2dup or 0= until ;
+: sign     0< if [char] - hold then ;
+

diff --git a/forth/test/core.fr b/forth/test/core.fr
index f326432b685d67df0a29cd99106f0d28f13adfed..0e9ced980ffadb03c274be9c0f3f7b31bfa4d145 100644 (file)
--- a/forth/test/core.fr
+++ b/forth/test/core.fr
@@ -795,8 +795,9 @@ T{ GE7 -> 124 }T
 \ ------------------------------------------------------------------------
 ." TESTING SOURCE >IN WORD" CR
 
-\ : GS1 S" SOURCE" 2DUP EVALUATE
-\        >R SWAP >R = R> R> = ;
+\ String is compiled into GS1 and is distinct from SOURCE.
+\ : GS1 S" SOURCE" 2DUP 2DUP EVALUATE
+\       >R SWAP >R = R> R> = ;
 \ T{ GS1 -> <TRUE> <TRUE> }T
 
 VARIABLE SCANS
@@ -805,8 +806,8 @@ T{ 2 SCANS !
 345 RESCAN?
 -> 345 345 }T
 
-\ : GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
-\ T{ GS2 -> 123 123 123 123 123 }T
+: GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
+T{ GS2 -> 123 123 123 123 123 }T
 
 : GS3 WORD COUNT SWAP C@ ;
 T{ BL GS3 HELLO -> 5 CHAR H }T
@@ -818,74 +819,73 @@ DROP -> 0 }T            \ BLANK LINE RETURN ZERO-LENGTH STRING
 T{ GS4 123 456
 -> }T
 
-\ \ ------------------------------------------------------------------------
-\ 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
-\       R> ?DUP IF         \ IF NON-EMPTY STRINGS
-\     0 DO
-\        OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
-\        SWAP CHAR+ SWAP CHAR+
-\          LOOP
-\       THEN
-\       2DROP <TRUE>         \ IF WE GET HERE, STRINGS MATCH
-\    ELSE
-\       R> DROP 2DROP <FALSE>      \ LENGTHS MISMATCH
-\    THEN ;
-\ 
-\ : GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
-\ T{ GP1 -> <TRUE> }T
-\ 
-\ : GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
-\ T{ GP2 -> <TRUE> }T
-\ 
-\ : GP3  <# 1 0 # # #> S" 01" S= ;
-\ T{ GP3 -> <TRUE> }T
-\ 
-\ : GP4  <# 1 0 #S #> S" 1" S= ;
-\ T{ GP4 -> <TRUE> }T
+\ ------------------------------------------------------------------------
+." TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL" CR
+
+: S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
+   >R SWAP R@ = IF         \ MAKE SURE STRINGS HAVE SAME LENGTH
+      R> ?DUP IF         \ IF NON-EMPTY STRINGS
+    0 DO
+       OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
+       SWAP CHAR+ SWAP CHAR+
+         LOOP
+      THEN
+      2DROP <TRUE>         \ IF WE GET HERE, STRINGS MATCH
+   ELSE
+      R> DROP 2DROP <FALSE>      \ LENGTHS MISMATCH
+   THEN ;
+
+: GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
+T{ GP1 -> <TRUE> }T
+
+: GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
+T{ GP2 -> <TRUE> }T
+
+: GP3  <# 1 0 # # #> S" 01" S= ;
+T{ GP3 -> <TRUE> }T
+
+: 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
 
-\ : GP5
-\    BASE @ <TRUE>
-\    MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
-\       I BASE !            \ TBD: ASSUMES BASE WORKS
-\       I 0 <# #S #> S" 10" S= AND
-\    LOOP
-\    SWAP BASE ! ;
-\ T{ GP5 -> <TRUE> }T
-\ 
-\ : GP6
-\    BASE @ >R  2 BASE !
-\    MAX-UINT MAX-UINT <# #S #>      \ MAXIMUM UD TO BINARY
-\    R> BASE !            \ S: C-ADDR U
-\    DUP #BITS-UD = SWAP
-\    0 DO               \ S: C-ADDR FLAG
-\       OVER C@ [CHAR] 1 = AND      \ ALL ONES
-\       >R CHAR+ R>
-\    LOOP SWAP DROP ;
-\ T{ GP6 -> <TRUE> }T
-\ 
-\ : GP7
-\    BASE @ >R    MAX-BASE BASE !
-\    <TRUE>
-\    A 0 DO
-\       I 0 <# #S #>
-\       1 = SWAP C@ I 30 + = AND AND
-\    LOOP
-\    MAX-BASE A DO
-\       I 0 <# #S #>
-\       1 = SWAP C@ 41 I A - + = AND AND
-\    LOOP
-\    R> BASE ! ;
-\ 
-\ T{ GP7 -> <TRUE> }T
+: GP5
+   BASE @ <TRUE>
+   MAX-BASE 1+ 2 DO         \ FOR EACH POSSIBLE BASE
+      I BASE !            \ TBD: ASSUMES BASE WORKS
+      I 0 <# #S #> S" 10" S= AND
+   LOOP
+   SWAP BASE ! ;
+T{ GP5 -> <TRUE> }T
+
+: GP6
+   BASE @ >R  2 BASE !
+   MAX-UINT MAX-UINT <# #S #>      \ MAXIMUM UD TO BINARY
+   R> BASE !            \ S: C-ADDR U
+   DUP #BITS-UD = SWAP
+   0 DO               \ S: C-ADDR FLAG
+      OVER C@ [CHAR] 1 = AND      \ ALL ONES
+      >R CHAR+ R>
+   LOOP SWAP DROP ;
+T{ GP6 -> <TRUE> }T
+
+: GP7
+   BASE @ >R    MAX-BASE BASE !
+   <TRUE>
+   A 0 DO
+      I 0 <# #S #>
+      1 = SWAP C@ I 30 + = AND AND
+   LOOP
+   MAX-BASE A DO
+      I 0 <# #S #>
+      1 = SWAP C@ 41 I A - + = AND AND
+   LOOP
+   R> BASE ! ;
+
+T{ GP7 -> <TRUE> }T
 
 \ >NUMBER TESTS
 CREATE GN-BUF 0 C,
@@ -910,17 +910,17 @@ 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 #>
-\    0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
-\    R> BASE ! ;
-\ T{ 0 0 2 GN1 -> 0 0 0 }T
-\ T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
-\ T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
-\ 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
+: GN1   \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
+   BASE @ >R BASE !
+   <# #S #>
+   0 0 2SWAP >NUMBER SWAP DROP      \ RETURN LENGTH ONLY
+   R> BASE ! ;
+T{ 0 0 2 GN1 -> 0 0 0 }T
+T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T
+T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T
+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 ! ;