alx/ueforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Capitalized branching.

Browse Source
This commit is contained in:
Brad Nelson
2022-07-30 12:38:39 -07:00
parent fdf8b760d1
commit 73d7181da2
3 changed files with 33 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
common/boot.fs
View File

@ -30,16 +30,16 @@ fp@ constant fp0
: [char] char aliteral ; immediate
( Core Control Flow )
create begin ' nop @ ' begin ! : begin ['] begin , here ; immediate
create again ' branch @ ' again ! : again ['] again , , ; immediate
create until ' 0branch @ ' until ! : until ['] until , , ; immediate
create ahead ' branch @ ' ahead ! : ahead ['] ahead , here 0 , ; immediate
create then ' nop @ ' then ! : then ['] then , here swap ! ; immediate
create if ' 0branch @ ' if ! : if ['] if , here 0 , ; immediate
create else ' branch @ ' else ! : else ['] else , here 0 , swap here swap ! ; immediate
create while ' 0branch @ ' while ! : while ['] while , here 0 , swap ; immediate
create repeat ' branch @ ' repeat ! : repeat ['] repeat , , here swap ! ; immediate
create aft ' branch @ ' aft ! : aft drop ['] aft , here 0 , here swap ; immediate
create BEGIN ' nop @ ' begin ! : begin ['] begin , here ; immediate
create AGAIN ' branch @ ' again ! : again ['] again , , ; immediate
create UNTIL ' 0branch @ ' until ! : until ['] until , , ; immediate
create AHEAD ' branch @ ' ahead ! : ahead ['] ahead , here 0 , ; immediate
create THEN ' nop @ ' then ! : then ['] then , here swap ! ; immediate
create IF ' 0branch @ ' if ! : if ['] if , here 0 , ; immediate
create ELSE ' branch @ ' else ! : else ['] else , here 0 , swap here swap ! ; immediate
create WHILE ' 0branch @ ' while ! : while ['] while , here 0 , swap ; immediate
create REPEAT ' branch @ ' repeat ! : repeat ['] repeat , , here swap ! ; immediate
create AFT ' branch @ ' aft ! : aft drop ['] aft , here 0 , here swap ; immediate
( Recursion )
: recurse current @ @ aliteral ['] execute , ; immediate
@ -52,8 +52,8 @@ create aft ' branch @ ' aft ! : aft drop ['] aft , here 0 , here swap
variable nest-depth
( FOR..NEXT )
create for ' >r @ ' for ! : for 1 nest-depth +! ['] for , here ; immediate
create next ' donext @ ' next ! : next -1 nest-depth +! ['] next , , ; immediate
create FOR ' >r @ ' for ! : for 1 nest-depth +! ['] for , here ; immediate
create NEXT ' donext @ ' next ! : next -1 nest-depth +! ['] next , , ; immediate
( DO..LOOP )
variable leaving
@ -72,9 +72,9 @@ variable leaving
: +loop ( n -- ) postpone (+loop) postpone until
postpone unloop )leaving ; immediate
: loop 1 aliteral postpone +loop ; immediate
create i ' r@ @ ' i ! ( i is same as r@ )
: j ( -- n ) rp@ 3 cells - @ ;
: k ( -- n ) rp@ 5 cells - @ ;
create I ' r@ @ ' i ! ( i is same as r@ )
: J ( -- n ) rp@ 3 cells - @ ;
: K ( -- n ) rp@ 5 cells - @ ;
( Exceptions )
variable handler

6
common/forth_namespace_tests.fs
View File

@ -97,9 +97,9 @@ e: check-boot
out: throw
out: catch
out: handler
out: k
out: j
out: i
out: K
out: J
out: I
out: loop
out: +loop
out: leave

30
common/utils_tests.fs
View File

@ -56,37 +56,37 @@ e: test-see-string
e: test-see-begin-again
: test begin again ;
see test
out: : test begin again ;
out: : test BEGIN AGAIN ;
;e
e: test-see-begin-until
: test begin until ;
see test
out: : test begin until ;
out: : test BEGIN UNTIL ;
;e
e: test-see-begin-while-repeat
: test begin while repeat ;
see test
out: : test begin while repeat ;
out: : test BEGIN WHILE REPEAT ;
;e
e: test-see-ahead-then
: test ahead then ;
see test
out: : test ahead then ;
out: : test AHEAD THEN ;
;e
e: test-see-for-next
: test for i . next ;
see test
out: : test for i . next ;
out: : test FOR I . NEXT ;
;e
e: test-see-for-aft-next
: test for aft i . then next ;
see test
out: : test for aft i . then next ;
out: : test FOR AFT I . THEN NEXT ;
;e
e: test-see-string-strides
@ -100,23 +100,23 @@ e: test-see-string-strides
: test7 1 if ." ------>" then ;
: test8 1 if ." ------->" then ;
see test0
out: : test0 1 if s" " type then ;
out: : test0 1 IF s" " type THEN ;
see test1
out: : test1 1 if s" >" type then ;
out: : test1 1 IF s" >" type THEN ;
see test2
out: : test2 1 if s" ->" type then ;
out: : test2 1 IF s" ->" type THEN ;
see test3
out: : test3 1 if s" -->" type then ;
out: : test3 1 IF s" -->" type THEN ;
see test4
out: : test4 1 if s" --->" type then ;
out: : test4 1 IF s" --->" type THEN ;
see test5
out: : test5 1 if s" ---->" type then ;
out: : test5 1 IF s" ---->" type THEN ;
see test6
out: : test6 1 if s" ----->" type then ;
out: : test6 1 IF s" ----->" type THEN ;
see test7
out: : test7 1 if s" ------>" type then ;
out: : test7 1 IF s" ------>" type THEN ;
see test8
out: : test8 1 if s" ------->" type then ;
out: : test8 1 IF s" ------->" type THEN ;
;e
e: test-noname