From 9ccce3fd1831684a9074a3b4e243e80418265cd6 Mon Sep 17 00:00:00 2001 From: Clyne Sullivan Date: Wed, 22 Feb 2023 19:46:12 -0500 Subject: [PATCH] begin work on core extensions; fix does> --- README.md | 4 ++-- compat.txt | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ core.fth | 41 +++++++++++++++++++++++++++++------------ 3 files changed, 82 insertions(+), 14 deletions(-) diff --git a/README.md b/README.md index 077ff9b..1bf772b 100644 --- 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 927afc1..5c0cad6 100644 --- 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 3d97936..863228f 100644 --- 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 ;