diff --git a/README.md b/README.md index 434136e..eca6085 100644 --- 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 49d39cf..3ea8630 100644 --- 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 f16224a..ec4bcb5 100644 --- 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 f326432..0e9ced9 100644 --- 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 -> }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 UNLOOP EXIT THEN -\ SWAP CHAR+ SWAP CHAR+ -\ LOOP -\ THEN -\ 2DROP \ IF WE GET HERE, STRINGS MATCH -\ ELSE -\ R> DROP 2DROP \ LENGTHS MISMATCH -\ THEN ; -\ -\ : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; -\ T{ GP1 -> }T -\ -\ : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; -\ T{ GP2 -> }T -\ -\ : GP3 <# 1 0 # # #> S" 01" S= ; -\ T{ GP3 -> }T -\ -\ : GP4 <# 1 0 #S #> S" 1" S= ; -\ T{ GP4 -> }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 UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }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 @ -\ 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 -> }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 -> }T -\ -\ : GP7 -\ BASE @ >R MAX-BASE BASE ! -\ -\ 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 -> }T +: GP5 + BASE @ + 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 -> }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 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + 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 -> }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 ! ;