1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-12-25 17:08:07 +11:00

Copy core words to blkfs

This commit is contained in:
Virgil Dupras 2020-04-25 21:54:07 -04:00
parent 6767012ebd
commit 6f896caf7a
46 changed files with 574 additions and 1 deletions

View File

@ -5,7 +5,7 @@ MASTER INDEX
200 Z80 assembler 260 Cross compilation 200 Z80 assembler 260 Cross compilation
280 Z80 boot code 350 ACIA driver 280 Z80 boot code 350 ACIA driver
370 SD Card driver 390 Inner core 370 SD Card driver 390 Inner core
420 Core words

3
blk/269 Normal file
View File

@ -0,0 +1,3 @@
( b1 b2 -- )
: XPACKR 1+ SWAP DO I DUP . CRLF XPACK LOOP ;

14
blk/420 Normal file
View File

@ -0,0 +1,14 @@
Core words
These words follow Inner core words, but unlike them, these are
self-bootstrapping and don't depend on the Cross Compiler. They
will typically be included in source form right after a stage1
binary which will interpret it on boot and bootstrap 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 438 cmp
442 print 446 parse
453 readln 459 fmt
464 blk

16
blk/422 Normal file
View File

@ -0,0 +1,16 @@
: H@ HERE @ ;
: IMMEDIATE
CURRENT @ 1-
DUP C@ 128 OR SWAP C!
;
: [ INTERPRET ; IMMEDIATE
: ] R> DROP ;
: LITS 34 , SCPY ;
: LIT< WORD LITS ; IMMEDIATE
: LITA 36 , , ;
: '
WORD (find) (?br) [ 4 , ] EXIT
LIT< (wnf) (find) DROP EXECUTE
;
: ['] ' LITA ; IMMEDIATE

5
blk/423 Normal file
View File

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

13
blk/424 Normal file
View File

@ -0,0 +1,13 @@
: _ 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.
LITS: 34 == litWord
LITA: 36 == addrWord
COMPILE: Tough one. Get addr of caller word (example above
(br)) and then call LITA on it. )

15
blk/425 Normal file
View File

@ -0,0 +1,15 @@
: +! SWAP OVER @ + SWAP ! ;
: -^ SWAP - ;
: ALLOT HERE +! ;
: IF ( -- a | a: br cell addr )
COMPILE (?br)
H@ ( push a )
2 ALLOT ( br cell allot )
; IMMEDIATE
: THEN ( a -- | a: br cell addr )
DUP H@ -^ SWAP ( a-H a )
!
; IMMEDIATE

8
blk/426 Normal file
View File

@ -0,0 +1,8 @@
: 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

10
blk/427 Normal file
View File

@ -0,0 +1,10 @@
( During a CASE, the stack grows by 1 at each ENDOF so that
we can fill all those ENDOF branching addrs. So that we
know when to stop, we put a 0 on PSP. That's our stopgap. )
: CASE 0 COMPILE >R ; IMMEDIATE
: OF
COMPILE I COMPILE =
[COMPILE] IF
; IMMEDIATE
: ENDOF [COMPILE] ELSE ; IMMEDIATE

13
blk/428 Normal file
View File

@ -0,0 +1,13 @@
( At this point, we have something like "0 e1 e2 e3 val". We
want top drop val, and then call THEN as long as we don't
hit 0. )
: ENDCASE
BEGIN
DUP NOT IF
DROP COMPILE R> COMPILE DROP EXIT
THEN
[COMPILE] THEN
AGAIN
; IMMEDIATE

7
blk/429 Normal file
View File

@ -0,0 +1,7 @@
: CREATE
(entry) ( empty header with name )
11 ( 11 == cellWord )
C, ( write it )
;

14
blk/430 Normal file
View File

@ -0,0 +1,14 @@
: 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 )
;

13
blk/431 Normal file
View File

@ -0,0 +1,13 @@
: VARIABLE CREATE 2 ALLOT ;
: CONSTANT CREATE , DOES> @ ;
: / /MOD SWAP DROP ;
: MOD /MOD DROP ;
( In addition to pushing H@ this compiles 2 >R so that loop
variables are sent to PS at runtime )
: DO
COMPILE SWAP COMPILE >R COMPILE >R
H@
; IMMEDIATE

16
blk/432 Normal file
View File

@ -0,0 +1,16 @@
( Increase loop counter and returns whether we should loop. )
: _
R> ( IP, keep for later )
R> 1+ ( ip i+1 )
DUP >R ( ip i )
I' = ( ip f )
SWAP >R ( f )
;
( One could think that we should have a sub word to avoid all
these COMPILE, but we can't because otherwise it messes with
the RS )
: LOOP
COMPILE _ COMPILE (?br)
H@ - ,
COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
; IMMEDIATE

14
blk/433 Normal file
View File

@ -0,0 +1,14 @@
: LEAVE R> R> DROP I 1- >R >R ;
: ROLL
DUP NOT IF EXIT THEN
1+ DUP PICK ( n val )
SWAP 2 * (roll) ( val )
SWAP DROP
;
: 2DUP OVER OVER ;
: 2OVER 3 PICK 3 PICK ;
: 2SWAP 3 ROLL 3 ROLL ;

16
blk/434 Normal file
View File

@ -0,0 +1,16 @@
( a1 a2 u -- )
: MOVE
( u ) 0 DO
SWAP DUP I + C@ ( a2 a1 x )
ROT SWAP OVER I + ( a1 a2 x a2 )
C! ( a1 a2 )
LOOP
2DROP
;
: DELW 1- 0 SWAP C! ;
: PREV
3 - DUP @ ( a o )
- ( a-o )
;

16
blk/435 Normal file
View File

@ -0,0 +1,16 @@
: 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) NOT IF ABORT THEN
DUP HERE ! CURRENT ! ;

12
blk/436 Normal file
View File

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

13
blk/438 Normal file
View File

@ -0,0 +1,13 @@
( Words useful for complex comparison operations )
: >= < NOT ;
: <= > NOT ;
: 0>= 0< NOT ;
( n1 -- n1 true )
: <>{ 1 ;
( n1 f -- f )
: <>} SWAP DROP ;

15
blk/439 Normal file
View File

@ -0,0 +1,15 @@
: _|&
( n1 n2 cell )
>R >R DUP R> R> ( n1 n1 n2 cell )
@ EXECUTE ( n1 f )
;
( n1 f n2 -- n1 f )
: _|
CREATE , DOES>
( n1 f n2 cell )
ROT IF 2DROP 1 EXIT THEN ( n1 true )
_|&
;

15
blk/440 Normal file
View File

@ -0,0 +1,15 @@
: _&
CREATE , DOES>
( n1 f n2 cell )
ROT NOT IF 2DROP 0 EXIT THEN ( n1 true )
_|&
;
( All words below have this signature:
n1 f n2 -- n1 f )
' = _| |=
' = _& &=
' > _| |>
' > _& &>
' < _| |<
' < _& &<

11
blk/442 Normal file
View File

@ -0,0 +1,11 @@
( EMIT is needed for this unit to compile )
: (print)
BEGIN
C@+ ( a+1 c )
( exit if null )
DUP NOT IF 2DROP EXIT THEN
EMIT ( a )
AGAIN
;

15
blk/443 Normal file
View File

@ -0,0 +1,15 @@
: ."
34 , ( 34 == litWord )
BEGIN
C<
( 34 is ASCII for " )
DUP 34 = IF DROP 0 THEN
DUP C,
NOT UNTIL
COMPILE (print)
; IMMEDIATE
: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE
: (uflw) ABORT" stack underflow" ;

9
blk/444 Normal file
View File

@ -0,0 +1,9 @@
: BS 8 EMIT ;
: LF 10 EMIT ;
: CR 13 EMIT ;
: CRLF CR LF ;
: SPC 32 EMIT ;
: (wnf) (print) SPC ABORT" word not found" ;
: (ok) SPC ." ok" CRLF ;

11
blk/446 Normal file
View File

@ -0,0 +1,11 @@
( strings being sent to parse routines are always null
terminated )
: (parsec) ( a -- n f )
( apostrophe is ASCII 39 )
DUP C@ 39 = NOT IF 0 EXIT THEN ( a 0 )
DUP 2+ C@ 39 = NOT IF 0 EXIT THEN ( a 0 )
( surrounded by apos, good, return )
1+ C@ 1 ( n 1 )
;

15
blk/447 Normal file
View File

@ -0,0 +1,15 @@
( returns negative value on error )
: _ ( c -- n )
( '0' is ASCII 48 )
48 -
DUP 0< IF EXIT THEN ( bad )
DUP 10 < IF EXIT THEN ( good )
( 'a' is ASCII 97. 59 = 97 - 48 )
49 -
DUP 0< IF EXIT THEN ( bad )
DUP 6 < IF 10 + EXIT THEN ( good )
( bad )
255 -
;

15
blk/448 Normal file
View File

@ -0,0 +1,15 @@
: (parseh) ( a -- n f )
( '0': ASCII 0x30 'x': 0x78 0x7830: 30768 )
DUP @ 30768 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0x" prefix )
2+
0 ( a r )
BEGIN
SWAP C@+ ( r a+1 c )
DUP NOT IF 2DROP 1 EXIT THEN ( r, 1 )
_ ( r a n )
DUP 0< IF ROT 2DROP 0 EXIT THEN ( a 0 )
ROT 16 * + ( a r*16+n )
AGAIN
;

11
blk/449 Normal file
View File

@ -0,0 +1,11 @@
( returns negative value on error )
: _ ( c -- n )
( '0' is ASCII 48 )
48 -
DUP 0< IF EXIT THEN ( bad )
DUP 2 < IF EXIT THEN ( good )
( bad )
255 -
;

16
blk/450 Normal file
View File

@ -0,0 +1,16 @@
: (parseb) ( a -- n f )
( '0': ASCII 0x30 'b': 0x62 0x6230: 25136 )
DUP @ 25136 = NOT IF 0 EXIT THEN ( a 0 )
( We have "0b" prefix )
2+
0 ( a r )
BEGIN
SWAP C@+ ( r a+1 c )
DUP NOT IF 2DROP 1 EXIT THEN ( r 1 )
_ ( r a n )
DUP 0< IF ROT 2DROP 0 EXIT THEN ( a 0 )
ROT 2 * + ( a r*2+n )
AGAIN
;

10
blk/451 Normal file
View File

@ -0,0 +1,10 @@
: (parse) ( a -- n )
(parsec) IF EXIT THEN
(parseh) IF EXIT THEN
(parseb) IF EXIT THEN
(parsed) IF EXIT THEN
( nothing works )
LIT< (wnf) (find) IF EXECUTE ELSE ABORT THEN
;
' (parse) (parse*) !

13
blk/453 Normal file
View File

@ -0,0 +1,13 @@
64 CONSTANT INBUFSZ
: RDLNMEM+ 0x53 RAM+ @ + ;
( current position in INBUF )
: IN> 0 RDLNMEM+ ;
( points to INBUF )
: IN( 2 RDLNMEM+ ;
( points to INBUF's end )
: IN) INBUFSZ 2+ RDLNMEM+ ;
( flush input buffer )
( set IN> to IN( and set IN> @ to null )
: (infl) 0 IN( DUP IN> ! ! ;

16
blk/454 Normal file
View File

@ -0,0 +1,16 @@
( handle backspace: go back one char in IN>, if possible, then
emit SPC + BS )
: (inbs)
( already at IN( ? )
IN> @ IN( = IF EXIT THEN
IN> @ 1- IN> !
SPC BS
;
( cont.: read one char into input buffer and returns whether we
should continue, that is, whether CR was not met. )

16
blk/455 Normal file
View File

@ -0,0 +1,16 @@
: (rdlnc) ( -- f )
( buffer overflow? same as if we typed a newline )
IN> @ IN) = IF 0x0a ELSE KEY THEN ( c )
DUP 0x7f = IF DROP 0x8 THEN ( del? same as backspace )
DUP 0x0a = IF DROP 0xd THEN ( lf? same as cr )
( echo back )
DUP EMIT ( c )
( bacspace? handle and exit )
DUP 0x8 = IF (inbs) EXIT THEN
( write and advance )
DUP ( keep as result ) ( c c )
( We take advantage of the fact that c's MSB is always zero and
thus ! automatically null-terminates our string )
IN> @ ! 1 IN> +! ( c )
( if newline, replace with zero to indicate EOL )
DUP 0xd = IF DROP 0 THEN ;

16
blk/456 Normal file
View File

@ -0,0 +1,16 @@
( Read one line in input buffer and make IN> point to it )
: (rdln)
(infl) BEGIN (rdlnc) NOT 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<? )
;

12
blk/457 Normal file
View File

@ -0,0 +1,12 @@
( Initializes the readln subsystem )
: RDLN$
( 53 == rdln's memory )
H@ 0x53 RAM+ !
( 2 for IN>, plus 2 for extra bytes after buffer: 1 for
the last typed 0x0a and one for the following NULL. )
INBUFSZ 4 + ALLOT
(infl)
['] RDLN< 0x0c RAM+ !
1 0x06 RAM+ ! ( 06 == C<? )
;

16
blk/459 Normal file
View File

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

16
blk/460 Normal file
View File

@ -0,0 +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
;

16
blk/461 Normal file
View File

@ -0,0 +1,16 @@
: _ ( a -- a+8 )
DUP ( save for 2nd loop )
':' EMIT DUP .x SPC
4 0 DO
DUP @ 256 /MOD SWAP
.x .x SPC 2+
LOOP
DROP
8 0 DO
C@+
DUP <>{ 0x20 &< 0x7e |> <>}
IF DROP '.' THEN
EMIT
LOOP
CRLF
;

9
blk/462 Normal file
View File

@ -0,0 +1,9 @@
: DUMP ( n a -- )
LF
BEGIN
OVER 1 < IF 2DROP EXIT THEN
_
SWAP 8 - SWAP
AGAIN
;

12
blk/464 Normal file
View File

@ -0,0 +1,12 @@
: BLKMEM+ 0x57 RAM+ @ + ;
( n -- Fetches block n and write it to BLK( )
: BLK@* 0 BLKMEM+ ;
( n -- Write back BLK( to storage at block n )
: BLK!* 2 BLKMEM+ ;
( Current blk pointer in ( )
: BLK> 4 BLKMEM+ ;
( Whether buffer is dirty )
: BLKDTY 6 BLKMEM+ ;
: BLK( 8 BLKMEM+ ;

12
blk/465 Normal file
View File

@ -0,0 +1,12 @@
: BLK$
H@ 0x57 RAM+ !
( 1024 for the block, 8 for variables )
1032 ALLOT
( LOAD detects end of block with ASCII EOT. This is why
we write it there. EOT == 0x04 )
4 C,
0 BLKDTY !
-1 BLK> !
;

13
blk/466 Normal file
View File

@ -0,0 +1,13 @@
: BLK! ( -- )
BLK> @ BLK!* @ EXECUTE
0 BLKDTY !
;
: BLK@ ( n -- )
DUP BLK> @ = IF DROP EXIT THEN
BLKDTY @ IF BLK! THEN
DUP BLK> ! BLK@* @ EXECUTE
;
: BLK!! 1 BLKDTY ! ;

11
blk/467 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( + (print)
CRLF
LOOP
;

16
blk/468 Normal file
View File

@ -0,0 +1,16 @@
: _
(boot<)
DUP 4 = IF
( We drop our char, but also "a" from WORD: it won't
have the opportunity to balance PSP because we're
EXIT!ing. )
2DROP
( We're finished interpreting )
EXIT!
THEN
;
( 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. )

16
blk/469 Normal file
View File

@ -0,0 +1,16 @@
: LOAD
BLK> @ >R ( save restorable variables to RSP )
0x08 RAM+ @ >R
0x06 RAM+ @ >R ( C<? )
0x2e RAM+ @ >R ( boot ptr )
BLK@
BLK( 0x2e RAM+ ! ( Point to beginning of BLK )
['] _ 0x08 RAM+ ! ( 08 == C<* override )
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 ;

2
blk/470 Normal file
View File

@ -0,0 +1,2 @@
( b1 b2 -- )
: LOADR 1+ SWAP DO I DUP . CRLF LOAD LOOP ;