6502/VolksForth
1
0
Fork 0
mirror of https://github.com/forth-ev/VolksForth.git synced 2025-04-08 18:40:06 +00:00
Code Issues Projects Releases Wiki Activity

ANS-Forth Shim for VolksForth MS-DOS

Browse Source
This commit is contained in:
Carsten Strotmann 2020-06-25 10:35:41 +02:00
parent f75379025c
commit f4e8b18eb4
2 changed files with 69 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
msdos/ans-shim.fb Normal file
View File

@ -0,0 +1 @@
\\ ANSI Forth Shim for VolksForth cas 25jun20 \ ANS Forth Shim cas 25jun20 : cells 2* ; : cell+ 2+ ; : cell 1 cells ; : aligned ; : char+ 1+ ; : chars ; : s" [compile] " compile count ; immediate : [char] [compile] ascii ; immediate : char [compile] ascii ; 1 3 +thru .( ANS Forth Shim loaded ... ) cr \ ANS Forth Shim cas 25jun20 : lshift 0 ?DO 2* LOOP ; : rshift 0 ?DO 2/ 32767 and LOOP ; : s>d extend ; : fm/mod m/mod ; : sm/rem dup >r 2dup xor >r m/mod over IF r> 0< IF 1+ swap r> - swap ELSE rdrop THEN ELSE rdrop rdrop THEN ; : postpone ' dup >name c@ $40 and IF , ELSE [compile] compile compile , THEN ; immediate \ ANS Forth Shim cas 25jun20 : recurse last @ name> , ; immediate : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) BEGIN dup 0= IF exit THEN >r count digit? WHILE accumulate r> 1- REPEAT 1- r> ; : accept expect span @ ;

68
sources/msdos/ans-shim.fb.src Normal file
View File

@ -0,0 +1,68 @@
Screen 0 not modified
0 \\ ANSI Forth Shim for VolksForth cas 25jun20
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ ANS Forth Shim cas 25jun20
1
2 : cells 2* ;
3 : cell+ 2+ ;
4 : cell 1 cells ;
5 : aligned ;
6 : char+ 1+ ;
7 : chars ;
8
9 : s" [compile] " compile count ; immediate
10 : [char] [compile] ascii ; immediate
11 : char [compile] ascii ;
12
13 1 3 +thru .( ANS Forth Shim loaded ... ) cr
14
15
Screen 2 not modified
0 \ ANS Forth Shim cas 25jun20
1
2 : lshift 0 ?DO 2* LOOP ;
3 : rshift 0 ?DO 2/ 32767 and LOOP ;
4 : s>d extend ;
5 : fm/mod m/mod ;
6 : sm/rem dup >r 2dup xor >r m/mod
7 over IF r> 0< IF 1+ swap r> - swap ELSE rdrop THEN
8 ELSE rdrop rdrop THEN ;
9
10 : postpone ' dup >name c@ $40 and
11 IF , ELSE [compile] compile compile , THEN ; immediate
12
13
14
15
Screen 3 not modified
0 \ ANS Forth Shim cas 25jun20
1
2 : recurse last @ name> , ; immediate
3
4 : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
5 BEGIN dup 0= IF exit THEN
6 >r count digit? WHILE accumulate r> 1- REPEAT 1- r> ;
7
8 : accept expect span @ ;
9
10
11
12
13
14
15