Move most of the high layer of comp core into the low one

With KEY and EMIT being switch words, most of the high layer can
be defined before drivers.

In addition to this change, I've compacted core blocks which were
becoming quite sparse.
This commit is contained in:
Virgil Dupras 2020-10-28 18:06:58 -04:00
parent 8f3891f7d3
commit 705d68deec
55 changed files with 410 additions and 410 deletions

View File

@ -6,6 +6,7 @@ MASTER INDEX
160 AVR SPI programmer
170-259 unused 260 Cross compilation
280 Z80 boot code 350 Core words
400-410 unused
410 PS/2 keyboard subsystem 418 Z80 SPI Relay driver
420 SD Card subsystem 440 8086 boot code
470-519 unused 520 Fonts

View File

@ -6,4 +6,4 @@ impossible.
The gap between these 2 parts is the ideal place to put device
driver code. Load the low part with "353 LOAD", the high part
with "380 LOAD"
with "390 LOAD"

View File

@ -11,4 +11,4 @@
(resRS) 0 0x08 RAM+ ! ( C<* override ) (infl)
LIT" (main)" FIND DROP EXECUTE
;
1 25 LOADR+ ( xcomp core low )
1 33 LOADR+

14
blk/357 Normal file
View File

@ -0,0 +1,14 @@
( r c -- r f )
( Parse digit c and accumulate into result r.
Flag f is 0 when c was a valid digit, 1 when c was WS,
-1 when c was an invalid digit. )
: _pdacc
DUP 0x21 < IF DROP 1 EXIT THEN
( parse char )
( if bad, return "r -1" )
'0' -
DUP 10 < NOT IF DROP -1 EXIT THEN
( good, add to running result )
SWAP 10 * + ( r*10+n )
0 ( good )
;

28
blk/358
View File

@ -1,14 +1,14 @@
( r c -- r f )
( Parse digit c and accumulate into result r.
Flag f is 0 when c was a valid digit, 1 when c was WS,
-1 when c was an invalid digit. )
: _pdacc
DUP 0x21 < IF DROP 1 EXIT THEN
( parse char )
( if bad, return "r -1" )
'0' -
DUP 10 < NOT IF DROP -1 EXIT THEN
( good, add to running result )
SWAP 10 * + ( r*10+n )
0 ( good )
;
: _pd ( a -- n f, parse decimal )
( We read the first char outside of the loop because it *has*
to be nonzero, which means _pdacc *has* to return 0. )
C@+ OVER C@ 0 ( a len firstchar startat )
( if we have '-', we only advance. more processing later. )
SWAP '-' = IF 1+ THEN ( a len startat )
( We loop until _pdacc is nonzero, which means either WS or
non-digit. 1 means WS, which means parsing was a success.
-1 means non-digit, which means we have a non-decimal. )
0 ROT ROT ( len ) ( startat ) DO ( a r )
OVER I + C@ ( a r c ) _pdacc ( a r f )
IF DROP 1- 0 UNLOOP EXIT THEN LOOP ( a r )
( if we had '-', we need to invert result. )
SWAP C@ '-' = IF 0 -^ THEN 1 ( r 1 ) ;

24
blk/359
View File

@ -1,14 +1,10 @@
: _pd ( a -- n f, parse decimal )
( We read the first char outside of the loop because it *has*
to be nonzero, which means _pdacc *has* to return 0. )
C@+ OVER C@ 0 ( a len firstchar startat )
( if we have '-', we only advance. more processing later. )
SWAP '-' = IF 1+ THEN ( a len startat )
( We loop until _pdacc is nonzero, which means either WS or
non-digit. 1 means WS, which means parsing was a success.
-1 means non-digit, which means we have a non-decimal. )
0 ROT ROT ( len ) ( startat ) DO ( a r )
OVER I + C@ ( a r c ) _pdacc ( a r f )
IF DROP 1- 0 UNLOOP EXIT THEN LOOP ( a r )
( if we had '-', we need to invert result. )
SWAP C@ '-' = IF 0 -^ THEN 1 ( r 1 ) ;
( strings being sent to parse routines are always null
terminated )
: _pc ( a -- n f, parse character )
( apostrophe is ASCII 39 )
DUP 1+ C@ 39 = OVER 3 + C@ 39 = AND ( a f )
NOT IF 0 EXIT THEN ( a 0 )
( surrounded by apos, good, return )
2+ C@ 1 ( n 1 )
;

24
blk/360
View File

@ -1,10 +1,16 @@
( strings being sent to parse routines are always null
terminated )
: _pc ( a -- n f, parse character )
( apostrophe is ASCII 39 )
DUP 1+ C@ 39 = OVER 3 + C@ 39 = AND ( a f )
NOT IF 0 EXIT THEN ( a 0 )
( surrounded by apos, good, return )
2+ C@ 1 ( n 1 )
( returns negative value on error )
: _ ( c -- n )
DUP '0' '9' =><= IF '0' - EXIT THEN
DUP 'a' 'f' =><= IF 0x57 ( 'a' - 10 ) - EXIT THEN
DROP -1 ( bad )
;
: _ph ( a -- n f, parse hex )
( '0': ASCII 0x30 'x': 0x78 0x7830 )
DUP 1+ @ 0x7830 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0x" prefix )
DUP C@ ( a len )
0 SWAP 1+ ( len+1 ) 3 DO ( a r )
OVER I + C@ ( a r c ) _ ( a r n )
DUP 0< IF 2DROP 0 UNLOOP EXIT THEN
SWAP 4 LSHIFT + ( a r*16+n ) LOOP
NIP 1 ;

13
blk/361
View File

@ -1,16 +1,15 @@
( returns negative value on error )
: _ ( c -- n )
DUP '0' '9' =><= IF '0' - EXIT THEN
DUP 'a' 'f' =><= IF 0x57 ( 'a' - 10 ) - EXIT THEN
DUP '0' '1' =><= IF '0' - EXIT THEN
DROP -1 ( bad )
;
: _ph ( a -- n f, parse hex )
( '0': ASCII 0x30 'x': 0x78 0x7830 )
DUP 1+ @ 0x7830 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0x" prefix )
: _pb ( a -- n f, parse binary )
( '0': ASCII 0x30 'b': 0x62 0x6230 )
DUP 1+ @ 0x6230 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0b" prefix )
DUP C@ ( a len )
0 SWAP 1+ ( len+1 ) 3 DO ( a r )
OVER I + C@ ( a r c ) _ ( a r n )
DUP 0< IF 2DROP 0 UNLOOP EXIT THEN
SWAP 4 LSHIFT + ( a r*16+n ) LOOP
SWAP 1 LSHIFT + ( a r*2+n ) LOOP
NIP 1 ;

21
blk/362
View File

@ -1,15 +1,8 @@
( returns negative value on error )
: _ ( c -- n )
DUP '0' '1' =><= IF '0' - EXIT THEN
DROP -1 ( bad )
: (parse) ( a -- n )
_pc IF EXIT THEN
_ph IF EXIT THEN
_pb IF EXIT THEN
_pd IF EXIT THEN
( nothing works )
(wnf)
;
: _pb ( a -- n f, parse binary )
( '0': ASCII 0x30 'b': 0x62 0x6230 )
DUP 1+ @ 0x6230 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0b" prefix )
DUP C@ ( a len )
0 SWAP 1+ ( len+1 ) 3 DO ( a r )
OVER I + C@ ( a r c ) _ ( a r n )
DUP 0< IF 2DROP 0 UNLOOP EXIT THEN
SWAP 1 LSHIFT + ( a r*2+n ) LOOP
NIP 1 ;

19
blk/363
View File

@ -1,8 +1,11 @@
: (parse) ( a -- n )
_pc IF EXIT THEN
_ph IF EXIT THEN
_pb IF EXIT THEN
_pd IF EXIT THEN
( nothing works )
(wnf)
;
: C<? 0x06 RAM+ @ ;
SYSVARS 0x0c + :** C<*
: C<
0x08 RAM+ ( C<* override ) @
?DUP NOT IF C<* ELSE EXECUTE THEN ;
: , H@ ! H@ 2+ HERE ! ;
: C, H@ C! H@ 1+ HERE ! ;
: ,"
BEGIN
C< DUP 34 ( ASCII " ) = IF DROP EXIT THEN C,
AGAIN ;

19
blk/364
View File

@ -1,11 +1,8 @@
: C<? 0x06 RAM+ @ ;
SYSVARS 0x0c + :** C<*
: C<
0x08 RAM+ ( C<* override ) @
?DUP NOT IF C<* ELSE EXECUTE THEN ;
: , H@ ! H@ 2+ HERE ! ;
: C, H@ C! H@ 1+ HERE ! ;
: ,"
BEGIN
C< DUP 34 ( ASCII " ) = IF DROP EXIT THEN C,
AGAIN ;
: WS? 33 < ;
: EOT? 4 = ; ( 4 == ASCII EOT, CTRL+D )
: EOT, 4 C, ;
: TOWORD
0 ( dummy ) BEGIN
DROP C< DUP WS? NOT OVER EOT? OR
UNTIL ;

21
blk/365
View File

@ -1,8 +1,13 @@
: WS? 33 < ;
: EOT? 4 = ; ( 4 == ASCII EOT, CTRL+D )
: EOT, 4 C, ;
: TOWORD
0 ( dummy ) BEGIN
DROP C< DUP WS? NOT OVER EOT? OR
UNTIL ;
( Read word from C<, copy to WORDBUF, null-terminate, and
return WORDBUF. )
: _wb 0x0e RAM+ ;
: _eot 0x0401 _wb ! _wb ;
: WORD
_wb 1+ TOWORD ( a c )
DUP EOT? IF 2DROP _eot EXIT THEN
BEGIN
OVER C! 1+ C< ( a c )
OVER 0x2e RAM+ = OVER WS? OR
UNTIL ( a c )
SWAP _wb - 1- ( ws len ) _wb C!
EOT? IF _eot ELSE _wb THEN ;

26
blk/366
View File

@ -1,13 +1,13 @@
( Read word from C<, copy to WORDBUF, null-terminate, and
return WORDBUF. )
: _wb 0x0e RAM+ ;
: _eot 0x0401 _wb ! _wb ;
: WORD
_wb 1+ TOWORD ( a c )
DUP EOT? IF 2DROP _eot EXIT THEN
BEGIN
OVER C! 1+ C< ( a c )
OVER 0x2e RAM+ = OVER WS? OR
UNTIL ( a c )
SWAP _wb - 1- ( ws len ) _wb C!
EOT? IF _eot ELSE _wb THEN ;
: IMMEDIATE
CURRENT @ 1-
DUP C@ 128 OR SWAP C! ;
: IMMED? 1- C@ 0x80 AND ;
: '? WORD FIND ;
: ' '? NOT IF (wnf) THEN ;
: ROLL
?DUP NOT IF EXIT THEN
1+ DUP PICK ( n val )
SWAP 2 * (roll) ( val )
NIP ;
: 2OVER 3 PICK 3 PICK ;
: 2SWAP 3 ROLL 3 ROLL ;

14
blk/367 Normal file
View File

@ -0,0 +1,14 @@
: MOVE ( a1 a2 u -- )
?DUP IF ( u ) 0 DO ( a1 a2 )
SWAP C@+ ( a2 a1+1 x )
ROT C!+ ( a1+1 a2+1 )
LOOP THEN 2DROP ;
: MOVE- ( a1 a2 u -- )
?DUP IF TUCK + 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 THEN 2DROP ;
: MOVE, ( a u -- ) H@ OVER ALLOT SWAP MOVE ;
: PREV 3 - DUP @ - ;

10
blk/368 Normal file
View File

@ -0,0 +1,10 @@
: [entry] ( w -- )
C@+ ( w+1 len ) TUCK MOVE, ( len )
( write prev value )
H@ CURRENT @ - ,
C, ( write size )
H@ CURRENT !
;
: (entry) WORD [entry] ;
: CREATE (entry) 2 ( cellWord ) C, ;
: VARIABLE CREATE 2 ALLOT ;

27
blk/369
View File

@ -1,13 +1,14 @@
: IMMEDIATE
CURRENT @ 1-
DUP C@ 128 OR SWAP C! ;
: IMMED? 1- C@ 0x80 AND ;
: '? WORD FIND ;
: ' '? NOT IF (wnf) THEN ;
: ROLL
?DUP NOT IF EXIT THEN
1+ DUP PICK ( n val )
SWAP 2 * (roll) ( val )
NIP ;
: 2OVER 3 PICK 3 PICK ;
: 2SWAP 3 ROLL 3 ROLL ;
: 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 !
;
: EMPTY LIT" _sys" FIND IF DUP HERE ! CURRENT ! THEN ;

27
blk/370
View File

@ -1,14 +1,13 @@
: MOVE ( a1 a2 u -- )
?DUP IF ( u ) 0 DO ( a1 a2 )
SWAP C@+ ( a2 a1+1 x )
ROT C!+ ( a1+1 a2+1 )
LOOP THEN 2DROP ;
: MOVE- ( a1 a2 u -- )
?DUP IF TUCK + 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 THEN 2DROP ;
: MOVE, ( a u -- ) H@ OVER ALLOT SWAP MOVE ;
: PREV 3 - DUP @ - ;
: DOES>
( Overwrite cellWord in CURRENT )
3 ( does ) 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 )
;
: CONSTANT CREATE , DOES> @ ;

14
blk/371
View File

@ -1,10 +1,4 @@
: [entry] ( w -- )
C@+ ( w+1 len ) TUCK MOVE, ( len )
( write prev value )
H@ CURRENT @ - ,
C, ( write size )
H@ CURRENT !
;
: (entry) WORD [entry] ;
: CREATE (entry) 2 ( cellWord ) C, ;
: VARIABLE CREATE 2 ALLOT ;
: [IF]
IF EXIT THEN
LIT" [THEN]" BEGIN DUP WORD S= UNTIL DROP ;
: [THEN] ;

24
blk/372
View File

@ -1,14 +1,10 @@
: 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 !
;
: EMPTY LIT" _sys" FIND IF DUP HERE ! CURRENT ! THEN ;
( n -- Fetches block n and write it to BLK( )
: BLK@* 0x34 RAM+ ;
( n -- Write back BLK( to storage at block n )
: BLK!* 0x36 RAM+ ;
( Current blk pointer in ( )
: BLK> 0x38 RAM+ ;
( Whether buffer is dirty )
: BLKDTY 0x3a RAM+ ;
: BLK( 0x3c RAM+ @ ;
: BLK) BLK( 1024 + ;

20
blk/373
View File

@ -1,13 +1,9 @@
: DOES>
( Overwrite cellWord in CURRENT )
3 ( does ) 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 )
: BLK$
H@ 0x3c ( BLK(* ) RAM+ !
1024 ALLOT
( LOAD detects end of block with ASCII EOT. This is why
we write it there. )
EOT,
0 BLKDTY !
-1 BLK> !
;
: CONSTANT CREATE , DOES> @ ;

18
blk/374
View File

@ -1,4 +1,14 @@
: [IF]
IF EXIT THEN
LIT" [THEN]" BEGIN DUP WORD S= UNTIL DROP ;
: [THEN] ;
: BLK! ( -- )
BLK> @ BLK!* @ EXECUTE
0 BLKDTY ! ;
: FLUSH BLKDTY @ IF BLK! THEN ;
: BLK@ ( n -- )
DUP BLK> @ = IF DROP EXIT THEN
FLUSH DUP BLK> ! BLK@* @ EXECUTE ;
: BLK!! 1 BLKDTY ! ;
: WIPE BLK( 1024 0 FILL BLK!! ;
: WIPED? ( -- f )
1 ( f ) BLK) BLK( DO
I C@ IF DROP 0 ( f ) LEAVE THEN LOOP ;
: COPY ( src dst -- )
FLUSH SWAP BLK@ BLK> ! BLK! ;

16
blk/375 Normal file
View File

@ -0,0 +1,16 @@
: _
999 SWAP ( stop indicator )
BEGIN
?DUP NOT IF EXIT THEN
10 /MOD ( r q )
SWAP '0' + SWAP ( d q )
AGAIN ;
: . ( n -- )
?DUP NOT IF '0' EMIT EXIT THEN ( 0 is a special case )
( handle negative )
DUP 0< IF '-' EMIT -1 * THEN
_
BEGIN
DUP '9' > IF DROP EXIT THEN ( stop indicator )
EMIT
AGAIN ;

26
blk/376
View File

@ -1,10 +1,16 @@
( n -- Fetches block n and write it to BLK( )
: BLK@* 0x34 RAM+ ;
( n -- Write back BLK( to storage at block n )
: BLK!* 0x36 RAM+ ;
( Current blk pointer in ( )
: BLK> 0x38 RAM+ ;
( Whether buffer is dirty )
: BLKDTY 0x3a RAM+ ;
: BLK( 0x3c RAM+ @ ;
: BLK) BLK( 1024 + ;
: ? @ . ;
: _
DUP 9 > IF 10 - 'a' +
ELSE '0' + THEN
;
( For hex display, there are no negatives )
: .x
256 MOD ( ensure < 0x100 )
16 /MOD ( l h )
_ EMIT ( l )
_ EMIT
;
: .X
256 /MOD ( l h )
.x .x
;

20
blk/377
View File

@ -1,9 +1,13 @@
: BLK$
H@ 0x3c ( BLK(* ) RAM+ !
1024 ALLOT
( LOAD detects end of block with ASCII EOT. This is why
we write it there. )
EOT,
0 BLKDTY !
-1 BLK> !
: _ ( a -- a+8 )
DUP ( a a )
':' EMIT DUP .x SPC
4 0 DO DUP @ 256 /MOD SWAP .x .x SPC 2+ LOOP
DROP ( a )
8 0 DO
C@+ DUP 0x20 0x7e =><= NOT IF DROP '.' THEN EMIT
LOOP NL ;
: DUMP ( n a -- )
LF
SWAP 8 /MOD SWAP IF 1+ THEN
0 DO _ LOOP
;

27
blk/378
View File

@ -1,14 +1,13 @@
: BLK! ( -- )
BLK> @ BLK!* @ EXECUTE
0 BLKDTY ! ;
: FLUSH BLKDTY @ IF BLK! THEN ;
: BLK@ ( n -- )
DUP BLK> @ = IF DROP EXIT THEN
FLUSH DUP BLK> ! BLK@* @ EXECUTE ;
: BLK!! 1 BLKDTY ! ;
: WIPE BLK( 1024 0 FILL BLK!! ;
: WIPED? ( -- f )
1 ( f ) BLK) BLK( DO
I C@ IF DROP 0 ( f ) LEAVE THEN LOOP ;
: COPY ( src dst -- )
FLUSH SWAP BLK@ BLK> ! BLK! ;
( handle backspace: go back one char in IN>, if possible, then
emit BS + SPC + BS )
: _bs
( already at IN( ? )
IN> @ IN( = IF EXIT THEN
IN> @ 1- IN> !
BS SPC BS
;
( del is same as backspace )
: BS? DUP 0x7f = SWAP 0x8 = OR ;
SYSVARS 0x55 + :** KEY
( cont.: read one char into input buffer and returns whether we
should continue, that is, whether CR was not met. )

View File

17
blk/380
View File

@ -1 +1,16 @@
1 20 LOADR+ ( xcomp core high )
( Read one line in input buffer and make IN> point to it )
: (rdln)
( EOT or less triggers line flush )
(infl) BEGIN (rdlnc) 5 < UNTIL
LF IN( IN> ! ;
( And finally, implement C<* )
: RDLN<
IN> @ C@
DUP IF ( not EOL? good, inc and return )
1 IN> +!
ELSE ( EOL ? readline. we still return null though )
(rdln)
THEN
( update C<? flag )
IN> @ C@ 0 > 0x06 RAM+ ! ( 06 == C<? )
;

10
blk/381 Normal file
View File

@ -0,0 +1,10 @@
( Initializes the readln subsystem )
: RDLN$
H@ 0x32 ( IN(* ) RAM+ !
( plus 2 for extra bytes after buffer: 1 for
the last typed 0x0a and one for the following NULL. )
IN) IN( - ALLOT
(infl)
['] RDLN< ['] C<* **!
1 0x06 RAM+ ! ( 06 == C<? )
;

11
blk/382 Normal file
View File

@ -0,0 +1,11 @@
: .2 DUP 10 < IF SPC THEN . ;
: LIST
BLK@
16 0 DO
I 1+ .2 SPC
64 I * BLK( + DUP 64 + SWAP DO
I C@ 0x20 MAX EMIT
LOOP
NL
LOOP
;

27
blk/383
View File

@ -1,16 +1,15 @@
: _
999 SWAP ( stop indicator )
: INTERPRET
BEGIN
?DUP NOT IF EXIT THEN
10 /MOD ( r q )
SWAP '0' + SWAP ( d q )
AGAIN ;
: . ( n -- )
?DUP NOT IF '0' EMIT EXIT THEN ( 0 is a special case )
( handle negative )
DUP 0< IF '-' EMIT -1 * THEN
_
BEGIN
DUP '9' > IF DROP EXIT THEN ( stop indicator )
EMIT
WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN
FIND NOT IF (parse) ELSE EXECUTE THEN
C<? NOT IF SPC LIT" ok" (print) NL THEN
AGAIN ;
( Read from BOOT C< PTR and inc it. )
: (boot<)
( 2e == BOOT C< PTR )
0x2e ( BOOT C< PTR ) RAM+ @ DUP C@ ( a c )
SWAP 1 + 0x2e RAM+ ! ( c ) ;
( pre-comment for tight LOAD: The 0x08==I check after INTERPRET
is to check whether we're restoring to "_", the word above.
if yes, then we're in a nested load. Also, the 1 in 0x06 is
to avoid tons of "ok" displays. )

32
blk/384
View File

@ -1,16 +1,16 @@
: ? @ . ;
: _
DUP 9 > IF 10 - 'a' +
ELSE '0' + THEN
;
( For hex display, there are no negatives )
: .x
256 MOD ( ensure < 0x100 )
16 /MOD ( l h )
_ EMIT ( l )
_ EMIT
;
: .X
256 /MOD ( l h )
.x .x
;
: LOAD
BLK> @ >R ( save restorable variables to RSP )
0x08 RAM+ @ >R ( 08 == C<* override )
0x06 RAM+ @ >R ( C<? )
0x2e RAM+ @ >R ( boot ptr )
BLK@
BLK( 0x2e RAM+ ! ( Point to beginning of BLK )
['] (boot<) 0x08 RAM+ !
1 0x06 RAM+ ! ( 06 == C<? )
INTERPRET
R> 0x2e RAM+ ! R> 0x06 RAM+ !
I 0x08 RAM+ @ = IF ( nested load )
R> DROP ( C<* ) R> BLK@
ELSE ( not nested )
R> 0x08 RAM+ ! R> DROP ( BLK> )
THEN ;

28
blk/385
View File

@ -1,13 +1,15 @@
: _ ( a -- a+8 )
DUP ( a a )
':' EMIT DUP .x SPC
4 0 DO DUP @ 256 /MOD SWAP .x .x SPC 2+ LOOP
DROP ( a )
8 0 DO
C@+ DUP 0x20 0x7e =><= NOT IF DROP '.' THEN EMIT
LOOP NL ;
: DUMP ( n a -- )
LF
SWAP 8 /MOD SWAP IF 1+ THEN
0 DO _ LOOP
;
: LOAD+ BLK> @ + LOAD ;
( b1 b2 -- )
: LOADR 1+ SWAP DO I DUP . NL LOAD LOOP ;
: LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ;
( Now, adev stuff )
SYSVARS 0x3e + :** A@
SYSVARS 0x40 + :** A!
( src dst u -- )
: AMOVE
( u ) 0 DO
SWAP DUP I + A@ ( dst src x )
ROT TUCK I + ( src dst x dst )
A! ( src dst )
LOOP 2DROP ;

View File

13
blk/387
View File

@ -1,13 +0,0 @@
( handle backspace: go back one char in IN>, if possible, then
emit BS + SPC + BS )
: _bs
( already at IN( ? )
IN> @ IN( = IF EXIT THEN
IN> @ 1- IN> !
BS SPC BS
;
( del is same as backspace )
: BS? DUP 0x7f = SWAP 0x8 = OR ;
SYSVARS 0x55 + :** KEY
( cont.: read one char into input buffer and returns whether we
should continue, that is, whether CR was not met. )

16
blk/389
View File

@ -1,16 +0,0 @@
( Read one line in input buffer and make IN> point to it )
: (rdln)
( EOT or less triggers line flush )
(infl) BEGIN (rdlnc) 5 < UNTIL
LF IN( IN> ! ;
( And finally, implement C<* )
: RDLN<
IN> @ C@
DUP IF ( not EOL? good, inc and return )
1 IN> +!
ELSE ( EOL ? readline. we still return null though )
(rdln)
THEN
( update C<? flag )
IN> @ C@ 0 > 0x06 RAM+ ! ( 06 == C<? )
;

26
blk/390
View File

@ -1,10 +1,16 @@
( Initializes the readln subsystem )
: RDLN$
H@ 0x32 ( IN(* ) RAM+ !
( plus 2 for extra bytes after buffer: 1 for
the last typed 0x0a and one for the following NULL. )
IN) IN( - ALLOT
(infl)
['] RDLN< ['] C<* **!
1 0x06 RAM+ ! ( 06 == C<? )
;
( xcomp core high )
: (main) INTERPRET BYE ;
: BOOT
0x02 RAM+ CURRENT* !
CURRENT @ 0x2e RAM+ ! ( 2e == BOOT C< PTR )
0 0x08 RAM+ ! ( 08 == C<* override )
['] (emit) ['] EMIT **! ['] (key) ['] KEY **!
['] CRLF ['] NL **!
['] (boot<) ['] C<* **!
['] C@ ['] A@ **! ['] C! ['] A! **!
( boot< always has a char waiting. 06 == C<?* )
1 0x06 RAM+ ! INTERPRET
RDLN$ LIT" _sys" [entry]
LIT" Collapse OS" (print) NL (main) ;
XCURRENT @ _xapply ORG @ 0x04 ( stable ABI BOOT ) + !
1 4 LOADR+

15
blk/391
View File

@ -1,11 +1,4 @@
: .2 DUP 10 < IF SPC THEN . ;
: LIST
BLK@
16 0 DO
I 1+ .2 SPC
64 I * BLK( + DUP 64 + SWAP DO
I C@ 0x20 MAX EMIT
LOOP
NL
LOOP
;
( Now we have "as late as possible" stuff. See bootstrap doc. )
: :* ( addr -- ) (entry) 4 ( alias ) C, , ;
: :** ( addr -- ) (entry) 5 ( switch ) C, , ;

25
blk/392
View File

@ -1,15 +1,14 @@
: INTERPRET
: _bchk DUP 0x7f + 0xff > IF LIT" br ovfl" (print) ABORT THEN ;
: DO COMPILE 2>R H@ ; IMMEDIATE
: LOOP COMPILE (loop) H@ - _bchk C, ; IMMEDIATE
( LEAVE is implemented in low xcomp )
: LITN COMPILE (n) , ;
( gets its name at the very end. can't comment afterwards )
: _ BEGIN LIT" )" WORD S= UNTIL ; IMMEDIATE
: _ ( : will get its name almost at the very end )
(entry) 1 ( compiled ) C,
BEGIN
WORD DUP @ 0x0401 = ( EOT ) IF DROP EXIT THEN
FIND NOT IF (parse) ELSE EXECUTE THEN
C<? NOT IF SPC LIT" ok" (print) NL THEN
WORD DUP LIT" ;" S= IF DROP COMPILE EXIT EXIT THEN
FIND IF ( is word ) DUP IMMED? IF EXECUTE ELSE , THEN
ELSE ( maybe number ) (parse) LITN THEN
AGAIN ;
( Read from BOOT C< PTR and inc it. )
: (boot<)
( 2e == BOOT C< PTR )
0x2e ( BOOT C< PTR ) RAM+ @ DUP C@ ( a c )
SWAP 1 + 0x2e RAM+ ! ( c ) ;
( pre-comment for tight LOAD: The 0x08==I check after INTERPRET
is to check whether we're restoring to "_", the word above.
if yes, then we're in a nested load. Also, the 1 in 0x06 is
to avoid tons of "ok" displays. )

32
blk/393
View File

@ -1,16 +1,16 @@
: LOAD
BLK> @ >R ( save restorable variables to RSP )
0x08 RAM+ @ >R ( 08 == C<* override )
0x06 RAM+ @ >R ( C<? )
0x2e RAM+ @ >R ( boot ptr )
BLK@
BLK( 0x2e RAM+ ! ( Point to beginning of BLK )
['] (boot<) 0x08 RAM+ !
1 0x06 RAM+ ! ( 06 == C<? )
INTERPRET
R> 0x2e RAM+ ! R> 0x06 RAM+ !
I 0x08 RAM+ @ = IF ( nested load )
R> DROP ( C<* ) R> BLK@
ELSE ( not nested )
R> 0x08 RAM+ ! R> DROP ( BLK> )
THEN ;
: IF ( -- a | a: br cell addr )
COMPILE (?br) H@ 1 ALLOT ( br cell allot )
; IMMEDIATE
: THEN ( a -- | a: br cell addr )
DUP H@ -^ _bchk SWAP ( a-H a ) C!
; IMMEDIATE
: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell )
COMPILE (br)
1 ALLOT
[COMPILE] THEN
H@ 1- ( push a. 1- for allot offset )
; IMMEDIATE
: LIT"
COMPILE (s) H@ 0 C, ,"
DUP H@ -^ 1- ( a len ) SWAP C!
; IMMEDIATE

28
blk/394
View File

@ -1,15 +1,13 @@
: LOAD+ BLK> @ + LOAD ;
( b1 b2 -- )
: LOADR 1+ SWAP DO I DUP . NL LOAD LOOP ;
: LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ;
( Now, adev stuff )
SYSVARS 0x3e + :** A@
SYSVARS 0x40 + :** A!
( src dst u -- )
: AMOVE
( u ) 0 DO
SWAP DUP I + A@ ( dst src x )
ROT TUCK I + ( src dst x dst )
A! ( src dst )
LOOP 2DROP ;
( We don't use ." and ABORT in core, they're not xcomp-ed )
: ." [COMPILE] LIT" COMPILE (print) ; IMMEDIATE
: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE
: BEGIN H@ ; IMMEDIATE
: AGAIN COMPILE (br) H@ - _bchk C, ; IMMEDIATE
: UNTIL COMPILE (?br) H@ - _bchk C, ; IMMEDIATE
: [ INTERPRET ; IMMEDIATE
: ] R> DROP ;
: COMPILE ' LITN ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: ['] ' LITN ; IMMEDIATE
':' X' _ 4 - C! ( give : its name )
'(' X' _ 4 - C!

16
blk/396
View File

@ -1,16 +0,0 @@
: (main) INTERPRET BYE ;
: BOOT
0x02 RAM+ CURRENT* !
CURRENT @ 0x2e RAM+ ! ( 2e == BOOT C< PTR )
0 0x08 RAM+ ! ( 08 == C<* override )
['] (emit) ['] EMIT **!
['] (key) ['] KEY **!
['] CRLF ['] NL **!
( 0c == C<* )
['] (boot<) ['] C<* **!
['] C@ ['] A@ ! ['] C! ['] A! **!
( boot< always has a char waiting. 06 == C<?* )
1 0x06 RAM+ ! INTERPRET
RDLN$ LIT" _sys" [entry]
LIT" Collapse OS" (print) NL (main) ;
XCURRENT @ _xapply ORG @ 0x04 ( stable ABI BOOT ) + !

View File

@ -1,4 +0,0 @@
( Now we have "as late as possible" stuff. See bootstrap doc. )
: :* ( addr -- ) (entry) 4 ( alias ) C, , ;
: :** ( addr -- ) (entry) 5 ( switch ) C, , ;

14
blk/398
View File

@ -1,14 +0,0 @@
: _bchk DUP 0x7f + 0xff > IF LIT" br ovfl" (print) ABORT THEN ;
: DO COMPILE 2>R H@ ; IMMEDIATE
: LOOP COMPILE (loop) H@ - _bchk C, ; IMMEDIATE
( LEAVE is implemented in low xcomp )
: LITN COMPILE (n) , ;
( gets its name at the very end. can't comment afterwards )
: _ BEGIN LIT" )" WORD S= UNTIL ; IMMEDIATE
: _ ( : will get its name almost at the very end )
(entry) 1 ( compiled ) C,
BEGIN
WORD DUP LIT" ;" S= IF DROP COMPILE EXIT EXIT THEN
FIND IF ( is word ) DUP IMMED? IF EXECUTE ELSE , THEN
ELSE ( maybe number ) (parse) LITN THEN
AGAIN ;

16
blk/399
View File

@ -1,16 +0,0 @@
: IF ( -- a | a: br cell addr )
COMPILE (?br) H@ 1 ALLOT ( br cell allot )
; IMMEDIATE
: THEN ( a -- | a: br cell addr )
DUP H@ -^ _bchk SWAP ( a-H a ) C!
; IMMEDIATE
: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell )
COMPILE (br)
1 ALLOT
[COMPILE] THEN
H@ 1- ( push a. 1- for allot offset )
; IMMEDIATE
: LIT"
COMPILE (s) H@ 0 C, ,"
DUP H@ -^ 1- ( a len ) SWAP C!
; IMMEDIATE

13
blk/400
View File

@ -1,13 +0,0 @@
( We don't use ." and ABORT in core, they're not xcomp-ed )
: ." [COMPILE] LIT" COMPILE (print) ; IMMEDIATE
: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE
: BEGIN H@ ; IMMEDIATE
: AGAIN COMPILE (br) H@ - _bchk C, ; IMMEDIATE
: UNTIL COMPILE (?br) H@ - _bchk C, ; IMMEDIATE
: [ INTERPRET ; IMMEDIATE
: ] R> DROP ;
: COMPILE ' LITN ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: ['] ' LITN ; IMMEDIATE
':' X' _ 4 - C! ( give : its name )
'(' X' _ 4 - C!

Binary file not shown.

View File

@ -69,7 +69,7 @@ H@ 4 + XCURRENT ! ( make next CODE have 0 prev field )
0x35 CODE RSHIFT
0x36 CODE LSHIFT
0x37 CODE TICKS
353 LOAD ( xcomp core low )
353 LOAD ( xcomp core )
: (emit) 0 PC! ;
: (key) 0 PC@ ;
: EFS@
@ -85,7 +85,7 @@ H@ 4 + XCURRENT ! ( make next CODE have 0 prev field )
: COLS 80 ; : LINES 32 ;
: AT-XY 6 PC! ( y ) 5 PC! ( x ) ;
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !

View File

@ -16,7 +16,7 @@ CODE _ BX POPx, AX POPx, 5 INT, ;CODE
( 8086 port doesn't define PC@ and PC!, but test harness uses
it. Our forth binary uses INT 6 for retcode. )
CODE PC! AX POPx, ( discard ) AX POPx, 6 INT, ;CODE
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _ ( Update LATEST ) PC ORG @ 8 + !
," BLK$ "
," ' EFS@ BLK@* ! "

View File

@ -23,7 +23,7 @@ RS_ADDR 0x80 - CONSTANT SYSVARS
: COLS 80 ; : LINES 32 ;
: AT-XY 6 PC! ( y ) 5 PC! ( x ) ;
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !

View File

@ -8,6 +8,6 @@ RS_ADDR 0x80 - CONSTANT SYSVARS
604 LOAD ( KEY/EMIT drivers )
606 608 LOADR ( BLK drivers )
610 LOAD ( AT-XY drivers )
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _ ( Update LATEST ) PC ORG @ 8 + !
," BLK$ FD$ ' FD@ BLK@* ! ' FD! BLK!* ! " EOT,

View File

@ -6,7 +6,7 @@ RS_ADDR 0x80 - CONSTANT SYSVARS
262 LOAD ( xcomp ) 282 LOAD ( boot.z80.decl )
270 LOAD ( xcomp overrides ) 283 335 LOADR ( boot.z80 )
353 LOAD ( xcomp core low ) 603 605 LOADR ( acia )
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !

View File

@ -29,7 +29,7 @@ CURRENT @ XCURRENT !
CREATE ~FNT CPFNT7x7
603 608 LOADR ( VDP )
612 617 LOADR ( PAD )
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !

View File

@ -66,7 +66,7 @@ CURRENT @ XCURRENT !
CREATE ~FNT CPFNT3x5
605 610 LOADR ( LCD low )
616 620 LOADR ( KBD low )
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !

View File

@ -10,7 +10,7 @@ RS_ADDR 0x80 - CONSTANT SYSVARS
283 335 LOADR ( boot.z80 )
353 LOAD ( xcomp core low )
602 LOAD ( trs80 )
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !

View File

@ -34,7 +34,7 @@ CODE (key)
: FD$ ( select disk 0 )
0x09 ( seldisk ) 1 PC! 0 0 PC! ( sel disk 0 )
;
380 LOAD ( xcomp core high )
390 LOAD ( xcomp core high )
(entry) _
( Update LATEST )
PC ORG @ 8 + !