begin work on core extensions; fix does>

diff --git a/README.md b/README.md
index 077ff9bb23b16acc3cc485806663999e0eb0884b..1bf772b30eee093439beb4acc26506a91cb39315 100644 (file)
--- a/README.md
+++ b/README.md
@@ -6,9 +6,9 @@ Alee is a portable and concise Forth implementation in modern C++. Its primary a
 
 ## Compatibility
 
-A base dictionary is being built following the "core" [glossary](https://forth-standard.org/standard/core). Progress on implementation of these words is documented in `compat.txt`.
+A base dictionary is being built by working through the "core" and "core extension" [glossaries](https://forth-standard.org/standard/core). These word lists are included in `compat.txt`, with "yes" indicating that the word is implemented either in `core.fth` or within Alee itself.
 
-A `sys` is available which links to a C++ function for user-defined functionality.
+A `sys` word is available to provide access to user-defined C++ functions.
 
 ## Building
 

diff --git a/compat.txt b/compat.txt
index 927afc1310f386da6f0b0914c63e247e1685743b..5c0cad6c24254c1be05cd3bb06010960f188e615 100644 (file)
--- a/compat.txt
+++ b/compat.txt
@@ -134,3 +134,54 @@ yes 6.1.2510 [']
 yes 6.1.2520 [CHAR]
 yes 6.1.2540 ]
 
+6.2 Core extension words
+
+    6.2.0200 .(
+    6.2.0210 .R
+yes 6.2.0260 0<>
+yes 6.2.0280 0>
+yes 6.2.0340 2>R
+yes 6.2.0410 2R>
+yes 6.2.0415 2R@
+    6.2.0455 :NONAME
+yes 6.2.0500 <>
+    6.2.0620 ?DO
+yes 6.2.0698 ACTION-OF
+yes 6.2.0700 AGAIN
+    6.2.0825 BUFFER:
+    6.2.0855 C"
+    6.2.0873 CASE
+yes 6.2.0945 COMPILE,
+yes 6.2.1173 DEFER
+yes 6.2.1175 DEFER!
+yes 6.2.1177 DEFER@
+    6.2.1342 ENDCASE
+    6.2.1343 ENDOF
+    6.2.1350 ERASE
+yes 6.2.1485 FALSE
+yes 6.2.1660 HEX
+    6.2.1675 HOLDS
+yes 6.2.1725 IS
+yes 6.2.1850 MARKER
+yes 6.2.1930 NIP
+    6.2.1950 OF
+    6.2.2000 PAD
+    6.2.2008 PARSE
+    6.2.2020 PARSE-NAME
+yes 6.2.2030 PICK
+    6.2.2125 REFILL
+    6.2.2148 RESTORE-INPUT
+yes 6.2.2150 ROLL
+    6.2.2266 S\"
+    6.2.2182 SAVE-INPUT
+    6.2.2218 SOURCE-ID
+yes 6.2.2295 TO
+yes 6.2.2298 TRUE
+yes 6.2.2300 TUCK
+    6.2.2330 U.R
+    6.2.2350 U>
+    6.2.2395 UNUSED
+yes 6.2.2405 VALUE
+    6.2.2440 WITHIN
+    6.2.2530 [COMPILE]
+yes 6.2.2535 \

diff --git a/core.fth b/core.fth
index 3d979368747ef2b75ada69caaf30fd704507cf26..863228f411195d4934ae1033231973041af98659 100644 (file)
--- a/core.fth
+++ b/core.fth
@@ -35,6 +35,7 @@
 : _input   4 cells ;
 
 : decimal  1 1+ base ! 1010 base ! ;
+: hex      1 1+ base ! 10000 base ! ;
 
 : [']      ' postpone literal ; imm
 : [        0 state ! ; imm
@@ -42,6 +43,7 @@
 
 : 2r>      ['] r> , ['] r> , ['] swap , ; imm
 : 2>r      ['] swap , ['] >r , ['] >r , ; imm
+: 2r@      ['] r> , ['] r> , ['] 2dup , ['] >r , ['] >r , ['] swap , ; imm
 : r@       ['] r> , ['] dup , ['] >r , ; imm
 
 : 2!       swap over ! cell+ ! ;
@@ -53,6 +55,8 @@
 : <=       - 1- 0< ;
 : >        <= 0= ;
 : <>       = 0= ;
+: 0<>      0= 0= ;
+: 0>       0 > ;
 
 : if       ['] _jmp0 , here 0 , ; imm
 : then     here swap ! ; imm
@@ -62,6 +66,7 @@
 : while    swap 1+ swap postpone if -rot ; imm
 : repeat   ['] _jmp , , if postpone then then ; imm
 : until    ['] _jmp0 , , drop ; imm
+: again    postpone repeat ; imm
 
 : do       postpone 2>r here ; imm
 : unloop   postpone 2r> ['] 2drop , ; imm
@@ -105,6 +110,7 @@
 : [char]   char postpone literal ; imm
 
 : (        begin [char] ) key <> while repeat ; imm
+: \        _input @ begin dup 0 > while key drop 1- repeat drop ; imm
 
 : type     begin dup 0 > while swap dup c@ emit char+ swap 1- repeat 2drop ;
 : s"       state @ if ['] _jmp , here 0 , then
@@ -116,21 +122,30 @@
 : ."       postpone s" state @ if ['] type , else type then ; imm
 
 : create   align here bl word count nip cell+ allot align
-           ['] _lit , here 3 cells + , ['] exit , 0 ,
+           ['] _lit , here 3 cells + , ['] exit dup , ,
            dup @ 31 & over _latest @ - 6 << or over ! _latest ! ;
 : _latword _latest @
            dup @ 31 & + cell+ aligned ;
-: does>    _latword 2 cells +
+: _does>   _latword 2 cells +
            ['] _jmp over ! cell+
-           here swap ! ] ;
+           r@ 1 cells - @ swap ! ;
+: does>    ['] _jmp , here 2 cells + dup , 2 cells + ,
+           ['] _does> , ['] exit , ; imm
 : >body    cell+ @ ;
+: compile, postpone literal postpone execute ;
 
 : variable create 1 cells allot ;
-: constant create , does> ['] @ , postpone ; ;
-( TODO fix compile-time does>... above should simply be "does> @ ;" )
+: constant create , does> @ ;
+: value    constant ;
+: to       ' 4 cells + state @ if postpone literal ['] ! , else ! then ; imm
+: defer    create does> @ execute ;
+: defer@   >body @ ;
+: defer!   >body ! ;
+: is       state @ if postpone ['] postpone defer! else ' defer! then ; imm
+: action-of state @ if postpone ['] postpone defer@ else ' defer@ then ; imm
 
 -1 constant true
-0  constant false
+0 constant false
 
 : >in      _input 80 chars + cell+ _input @ - 4 chars - ;
 : source   _input @ 6 chars + >in 3 chars - swap ;
@@ -144,15 +159,17 @@
            rot dup @ >r cell+
            rot r> over ! cell+
            rot 1- repeat drop 2drop ;
-: fill     ( c-addr u char -- )
-           -rot begin dup 0 > while
+: fill     -rot begin dup 0 > while
            >r 2dup c! char+ r> 1- repeat
            2drop drop ;
+: roll     dup if swap >r 1- recurse r> swap exit then drop ;
 
 : environment? 2drop false ;
 
 : accept   over >r begin dup 0 > while
-           key dup 32 < if
-           2drop r> - 1 chars / 0 else
-           dup emit rot 2dup c! char+ nip swap 1- then
-           repeat drop ;
+           key dup 32 < if 2drop 0
+           else dup emit rot 2dup c! char+ nip swap 1- then
+           repeat drop r> - 1 chars / ;
+
+: marker   create _latest @ , here , does>
+           dup @ _latest ! cell+ @ here swap - allot ;