izaya/collapseos
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Pack core words a bit

Browse Source 
This leaves space for xcomp-core which is growing.
This commit is contained in:
Virgil Dupras 2020-05-12 21:27:06 -04:00
parent dfe474ca0e
commit cbf5baf3b6
20 changed files with 111 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
blk/001
View File

@ -7,7 +7,7 @@ MASTER INDEX
200 Z80 assembler 260 Cross compilation
280 Z80 boot code 350 ACIA driver
370 SD Card driver 390 Cross-compiled core
420 Core words 480 AT28 Driver
428 Core words 480 AT28 Driver
490 TRS-80 Recipe 520 Fonts
550 TI-84+ Recipe

10
blk/422
View File

@ -1,10 +0,0 @@
: [ INTERPRET ; IMMEDIATE
: ] R> DROP ;
: LIT< WORD 34 , SCPY 0 C, ; IMMEDIATE
: LITA 36 , , ;
: '? WORD (find) ;
: '
'? (?br) [ 4 , ] EXIT
LIT< (wnf) (find) DROP EXECUTE
;
: ['] ' LITA ; IMMEDIATE

5
blk/423
View File

@ -1,5 +0,0 @@
: COMPILE ' LITA ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: BEGIN H@ ; IMMEDIATE
: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
: UNTIL COMPILE (?br) H@ - , ; IMMEDIATE

13
blk/424
View File

@ -1,13 +0,0 @@
: _ BEGIN LIT< ) WORD S= UNTIL ; IMMEDIATE
40 CURRENT @ 4 - C!
( Hello, hello, krkrkrkr... do you hear me?
Ah, voice at last! Some lines above need comments
BTW: Forth lines limited to 64 cols because of default
input buffer size in Collapse OS
40 is ASCII for '('. We do this to simplify XPACK's task of
not mistakenly consider '(' definition as a comment.
LIT<: 34 == litWord
LITA: 36 == addrWord
COMPILE: Tough one. Get addr of caller word (example above
(br)) and then call LITA on it. )

12
blk/426
View File

@ -1,12 +0,0 @@
: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell )
COMPILE (br)
2 ALLOT
DUP H@ -^ SWAP ( a-H a )
!
H@ 2- ( push a. -2 for allot offset )
; IMMEDIATE
: [IF]
IF EXIT THEN
LIT< [THEN] BEGIN DUP WORD S= UNTIL DROP ;
: [THEN] ;

5
blk/420 → blk/428
View File

@ -8,6 +8,5 @@ itself to a full intepreter, which can then be relinked with
the Relinker. There is no loader for these libraries because
you will typically XPACK (B267) them.
422 core 440 print
442 fmt 447 readln
453 blk
430 core 442 fmt
447 readln 453 blk

27
blk/430
View File

@ -1,14 +1,15 @@
: DOES>
( Overwrite cellWord in CURRENT )
( 43 == doesWord )
43 CURRENT @ C!
( When we have a DOES>, we forcefully place HERE to 4
bytes after CURRENT. This allows a DOES word to use ","
and "C," without messing everything up. )
CURRENT @ 3 + HERE !
( HERE points to where we should write R> )
R> ,
( We're done. Because we've popped RS, we'll exit parent
definition )
: [ INTERPRET ; IMMEDIATE
: ] R> DROP ;
: LIT< WORD 34 , SCPY 0 C, ; IMMEDIATE
: LITA 36 , , ;
: '? WORD (find) ;
: '
'? (?br) [ 4 , ] EXIT
LIT< (wnf) (find) DROP EXECUTE
;
: ['] ' LITA ; IMMEDIATE
: COMPILE ' LITA ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: BEGIN H@ ; IMMEDIATE
: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
: UNTIL COMPILE (?br) H@ - , ; IMMEDIATE

19
blk/431
View File

@ -1,8 +1,13 @@
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE , DOES> @ ;
: _ BEGIN LIT< ) WORD S= UNTIL ; IMMEDIATE
40 CURRENT @ 4 - C!
( Hello, hello, krkrkrkr... do you hear me?
Ah, voice at last! Some lines above need comments
BTW: Forth lines limited to 64 cols because of default
input buffer size in Collapse OS
( In addition to pushing H@ this compiles 2>R so that loop
variables are sent to PS at runtime )
: DO COMPILE 2>R H@ ; IMMEDIATE
: LOOP COMPILE (loop) H@ - , ; IMMEDIATE
: LEAVE R> R> DROP I 1- >R >R ;
40 is ASCII for '('. We do this to simplify XPACK's task of
not mistakenly consider '(' definition as a comment.
LIT<: 34 == litWord
LITA: 36 == addrWord
COMPILE: Tough one. Get addr of caller word (example above
(br)) and then call LITA on it. )

0
blk/425 → blk/432
View File

21
blk/433
View File

@ -1,11 +1,12 @@
: ROLL
DUP NOT IF EXIT THEN
1+ DUP PICK ( n val )
SWAP 2 * (roll) ( val )
SWAP DROP
;
: 2OVER 3 PICK 3 PICK ;
: 2SWAP 3 ROLL 3 ROLL ;
: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell )
COMPILE (br)
2 ALLOT
DUP H@ -^ SWAP ( a-H a )
!
H@ 2- ( push a. -2 for allot offset )
; IMMEDIATE
: [IF]
IF EXIT THEN
LIT< [THEN] BEGIN DUP WORD S= UNTIL DROP ;
: [THEN] ;

27
blk/434
View File

@ -1,13 +1,14 @@
: MOVE ( a1 a2 u -- )
( u ) 0 DO ( a1 a2 )
SWAP C@+ ( a2 a1+1 x )
ROT C!+ ( a1+1 a2+1 )
LOOP 2DROP ;
: MOVE- ( a1 a2 u -- )
SWAP OVER + 1- ( a1 u a2+u-1 )
ROT 2 PICK + 1- ( u a2+u-1 a1+u-1 )
ROT ( u ) 0 DO ( a2 a1 )
C@- ( a2 a1-1 x )
ROT C!- ( a1-1 a2-1 ) SWAP ( a2 a1 )
LOOP 2DROP ;
: PREV 3 - DUP @ - ;
: DOES>
( Overwrite cellWord in CURRENT )
( 43 == doesWord )
43 CURRENT @ C!
( When we have a DOES>, we forcefully place HERE to 4
bytes after CURRENT. This allows a DOES word to use ","
and "C," without messing everything up. )
CURRENT @ 3 + HERE !
( HERE points to where we should write R> )
R> ,
( We're done. Because we've popped RS, we'll exit parent
definition )
;

21
blk/435
View File

@ -1,13 +1,8 @@
: WORD(
DUP 1- C@ ( name len field )
127 AND ( 0x7f. remove IMMEDIATE flag )
3 + ( fixed header len )
-
;
: FORGET
' DUP ( w w )
( HERE must be at the end of prev's word, that is, at the
beginning of w. )
WORD( HERE ! ( w )
PREV CURRENT !
;
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE , DOES> @ ;
( In addition to pushing H@ this compiles 2>R so that loop
variables are sent to PS at runtime )
: DO COMPILE 2>R H@ ; IMMEDIATE
: LOOP COMPILE (loop) H@ - , ; IMMEDIATE
: LEAVE R> R> DROP I 1- >R >R ;

17
blk/436
View File

@ -1,10 +1,11 @@
( Drop RSP until I-2 == INTERPRET. )
: EXIT!
['] INTERPRET ( I )
BEGIN ( I )
DUP ( I I )
R> DROP I 2- @ ( I I a )
= UNTIL
DROP
: ROLL
DUP NOT IF EXIT THEN
1+ DUP PICK ( n val )
SWAP 2 * (roll) ( val )
SWAP DROP
;
: 2OVER 3 PICK 3 PICK ;
: 2SWAP 3 ROLL 3 ROLL ;

13
blk/437 Normal file
View File

@ -0,0 +1,13 @@
: MOVE ( a1 a2 u -- )
( u ) 0 DO ( a1 a2 )
SWAP C@+ ( a2 a1+1 x )
ROT C!+ ( a1+1 a2+1 )
LOOP 2DROP ;
: MOVE- ( a1 a2 u -- )
SWAP OVER + 1- ( a1 u a2+u-1 )
ROT 2 PICK + 1- ( u a2+u-1 a1+u-1 )
ROT ( u ) 0 DO ( a2 a1 )
C@- ( a2 a1-1 x )
ROT C!- ( a1-1 a2-1 ) SWAP ( a2 a1 )
LOOP 2DROP ;
: PREV 3 - DUP @ - ;

13
blk/438 Normal file
View File

@ -0,0 +1,13 @@
: WORD(
DUP 1- C@ ( name len field )
127 AND ( 0x7f. remove IMMEDIATE flag )
3 + ( fixed header len )
-
;
: FORGET
' DUP ( w w )
( HERE must be at the end of prev's word, that is, at the
beginning of w. )
WORD( HERE ! ( w )
PREV CURRENT !
;

10
blk/439 Normal file
View File

@ -0,0 +1,10 @@
( Drop RSP until I-2 == INTERPRET. )
: EXIT!
['] INTERPRET ( I )
BEGIN ( I )
DUP ( I I )
R> DROP I 2- @ ( I I a )
= UNTIL
DROP
;

2
emul/xcomp.fs
View File

@ -21,7 +21,7 @@ CURRENT @ XCURRENT !
( Update LATEST )
PC ORG @ 8 + !
," CURRENT @ HERE ! "
422 459 XPACKR
430 459 XPACKR
," ' (key) 12 RAM+ ! "
ORG @ 256 /MOD 2 PC! 2 PC!
H@ 256 /MOD 2 PC! 2 PC!

2
recipes/rc2014/xcomp.fs
View File

@ -27,7 +27,7 @@ CURRENT @ XCURRENT !
(entry) _
( Update LATEST )
PC ORG @ 8 + !
422 452 XPACKR ( core print fmt readln )
430 452 XPACKR ( core fmt readln )
123 132 XPACKR ( linker )
," : _ ACIA$ RDLN$ (ok) ; _ "
ORG @ 256 /MOD 2 PC! 2 PC!

2
recipes/ti84/xcomp.fs
View File

@ -74,7 +74,7 @@ CREATE ~FNT CPFNT3x5
(entry) _
( Update LATEST )
PC ORG @ 8 + !
422 451 XPACKR ( core print fmt readln )
430 451 XPACKR ( core fmt readln )
," : _ LCD$ KBD$ (ok) RDLN$ ; _ "
ORG @ 0x100 - 256 /MOD 2 PC! 2 PC!
H@ 256 /MOD 2 PC! 2 PC!

2
recipes/trs80/xcomp.fs
View File

@ -21,7 +21,7 @@ CURRENT @ XCURRENT !
( Update LATEST )
PC ORG @ 8 + !
," CURRENT @ HERE ! "
422 459 XPACKR ( core print readln fmt blk )
430 459 XPACKR ( core readln fmt blk )
499 500 XPACKR ( trs80.fs )
( 0x0a == NLPTR. TRS-80 wants CR-only newlines )
," : _ ['] CR 0x0a RAM+ ! BLK$ FD$ (ok) RDLN$ ; _ "