bitgloo
/
alee-forth
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fix core and core-ext impl to pass all tests

Browse Source
optimize
Clyne 11 months ago
parent 3bb6ecbb23
commit 91566e20e8
Signed by: clyne
GPG Key ID: 3267C8EBF3F9AFC7
5 changed files with 43 additions and 44 deletions
Show Stats Download Patch File Download Diff File

19
forth/core-ext.fth
Unescape Escape View File

@ -21,21 +21,23 @@
: \ _source @ >in @ +
begin dup c@ while 0 over c! char+ repeat drop ; imm
: again postpone repeat ; imm
: ?do ['] 2dup , ['] _lit , here 0 , ['] >r , ['] = , postpone if
['] 2drop , postpone 2r> ['] drop , ['] >r , ['] leave ,
postpone then postpone 2>r here ; imm
: ?do ['] _lit , here 0 , ['] >r , ['] 2dup , postpone 2>r
['] = , postpone if postpone leave postpone then
here ; imm
: .( [char] ) word count type ; imm
: c" state @ if ['] _jmp , here 0 , then
[char] " word
state @ 0= if exit then
dup count nip allot
dup count nip 1+ allot
here rot !
postpone literal ; imm
: buffer: create allot ;
: value constant ;
: to ' 4 cells + state @ if postpone literal ['] ! , else ! then ; imm
: defer create does> @ execute ;
: defer@ >body @ ;
: defer! >body ! ;
@ -48,11 +50,10 @@
: marker here _latest @ create , , does>
dup @ _latest ! cell+ @ here - allot ;
: case ['] _lit , 1 here 0 , ['] drop , ; imm
: of ['] over , ['] = , postpone if ; imm
: endof ['] _jmp , here >r 0 , postpone then
swap 1+ swap r> tuck ! ; imm
: endcase swap 0 do dup @ swap here swap ! loop drop ['] drop , ; imm
: case 0 ; imm
: of ['] over , ['] = , postpone if ['] drop , ; imm
: endof postpone else ; imm
: endcase ['] drop , begin ?dup while postpone then repeat ; imm
: holds begin dup while 1- 2dup + c@ hold repeat 2drop ;

57
forth/core.fth
Unescape Escape View File

@ -21,13 +21,22 @@
: base 0 ;
: here 1 cells @ ;
: allot 1 cells +! ;
: c! 0 _! ;
: c@ 0 _@ ;
: c, here c! 1 allot ;
: char+ 1+ ;
: chars ;
: _latest 2 cells ;
: imm _latest @ dup @ 1 5 << | swap ! ;
: immediate imm ;
: state 3 cells ;
: _source 4 cells ;
: _sourceu 5 cells ;
: >in 6 cells ;
: _compxt 4 cells ;
: _source 5 cells ;
: _sourceu 6 cells ;
: >in 7 cells ;
: _begin 8 cells 80 chars + ;
: , here ! 1 cells allot ;
@ -54,12 +63,6 @@
: 2over 3 pick 3 pick ;
: 2swap rot >r rot r> ;
: c! 0 _! ;
: c@ 0 _@ ;
: c, here c! 1 allot ;
: char+ 1+ ;
: chars ;
: decimal 10 base ! ;
: 2r> ['] r> , ['] r> , ['] swap , ; imm
@ -82,23 +85,22 @@
: do ['] _lit , here 0 , ['] >r , postpone 2>r here ; imm
: unloop postpone 2r> ['] 2drop , ['] r> , ['] drop , ; imm
: leave postpone 2r> ['] 2drop , postpone 2r>
['] drop , ['] >r , ['] exit , ; imm
: leave postpone 2r> ['] 2drop , ['] exit , ; imm
: +loop ['] r> , ['] 2dup , ['] + ,
postpone r@ ['] swap , ['] >r ,
['] - , ['] 2dup , ['] + , ['] over , ['] ^ ,
['] rot , ['] rot , ['] ^ , ['] & , ['] _lit , 0 ,
['] < , ['] _jmp0 , ,
postpone unloop here swap ! ; imm
postpone unloop here 1 cells - swap ! ; imm
: loop postpone 2r> ['] 1+ , ['] 2dup ,
postpone 2>r ['] = , ['] _jmp0 , ,
postpone unloop here swap ! ; imm
postpone unloop here 1 cells - swap ! ; imm
: i postpone r@ ; imm
: j postpone 2r> ['] r> , postpone r@ ['] swap ,
['] >r , ['] -rot , postpone 2>r ; imm
: align here 1 cells 1- swap over & if 1 cells swap - allot else drop then ;
: aligned dup 1 cells 1- swap over & if 1 cells swap - + else drop then ;
: align here dup aligned swap - allot ;
: and & ;
: or | ;
@ -155,21 +157,18 @@
swap postpone literal postpone literal ; imm
: ." postpone s" state @ if ['] type , else type then ; imm
: create align here dup _latest @ - 1 1 cells 8 * 6 - << 1- swap <=
dup if -1 6 << , then 0 , >r
begin key? if key else bl then dup bl <> while
c, 1 over +! repeat drop align
['] _lit , here 3 cells + , ['] exit dup , ,
dup _latest @ - r> if
over cell+ else 6 << over then +! _latest ! ;
: _does> _latest @ dup @ 31 & + cell+ aligned 2 cells +
['] _jmp over ! cell+
r@ 1 cells - @ swap ! ;
: does> ['] _jmp , here 2 cells + dup , 2 cells + ,
['] _does> , ['] exit , ; imm
: :noname here dup _compxt ! 0 , here swap ] ;
: create : here 4 cells + postpone literal postpone ; 0 , ;
: >body cell+ @ ;
: _does> >r _latest @ dup @ 31 & + cell+ aligned 2 cells +
['] _jmp over ! cell+ r> cell+ swap ! ;
: does> state @ if
here 3 cells + postpone literal ['] _does> , ['] exit , else
here dup _does> dup _compxt ! 0 , ] then ; imm
: variable create 1 cells allot ;
: constant create , does> @ ;
@ -179,7 +178,7 @@
postpone if ['] type , ['] abort ,
postpone else ['] 2drop , postpone then ; imm
: recurse depth 1- pick dup @ 31 & + cell+ aligned , ; imm
: recurse _compxt @ dup @ 31 & + cell+ aligned , ; imm
: move dup 0 <= if drop 2drop exit then
>r 2dup < r> swap if
@ -198,8 +197,6 @@
else dup emit rot 2dup c! char+ swap drop swap 1- then
repeat drop r> - 1 chars / ;
: :noname here 0 , here swap ] ;
: evaluate _source @ >r _sourceu @ >r >in @ >r
0 >in ! _sourceu ! _source ! _ev
r> >in ! r> _sourceu ! r> _source ! ;

1
forth/tools.fth
Unescape Escape View File

@ -3,7 +3,6 @@
: dump hex 0 do i cells over + @ s>d <# # # # # bl hold #> type loop
drop decimal ;
7 cells 80 chars + constant _begin
: words _latest @ begin
dup @ dup 31 &
2 pick cell+ \ lt l len ws

1
libalee/corewords.cpp
Unescape Escape View File

@ -155,6 +155,7 @@ execute:
break;
case 22: // colon
state.push(state.dict.alignhere());
state.dict.write(Dictionary::CompToken, state.top());
while (!state.dict.hasInput())
state.input();
state.dict.addDefinition(state.dict.input());

9
libalee/dictionary.hpp
Unescape Escape View File

@ -47,11 +47,12 @@ public:
constexpr static Addr Here = sizeof(Cell);
constexpr static Addr Latest = sizeof(Cell) * 2;
constexpr static Addr Compiling = sizeof(Cell) * 3;
constexpr static Addr Source = sizeof(Cell) * 4;
constexpr static Addr SourceLen = sizeof(Cell) * 5;
constexpr static Addr Input = sizeof(Cell) * 6; // len data...
constexpr static Addr CompToken = sizeof(Cell) * 4;
constexpr static Addr Source = sizeof(Cell) * 5;
constexpr static Addr SourceLen = sizeof(Cell) * 6;
constexpr static Addr Input = sizeof(Cell) * 7; // len data...
constexpr static Addr InputCells = 80; // bytes!
constexpr static Addr Begin = sizeof(Cell) * 7 + InputCells;
constexpr static Addr Begin = sizeof(Cell) * 8 + InputCells;
constexpr static Cell Immediate = (1 << 5);

Write Preview
Loading…
Cancel
Save