begin work on core extensions; fix does>

llvm
Clyne 2 years ago
parent 0ede616831
commit 9ccce3fd18
Signed by: clyne
GPG Key ID: 3267C8EBF3F9AFC7

@ -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

@ -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 \

@ -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,18 +122,27 @@
: ." 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
@ -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 ;

Loading…
Cancel
Save