1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-02 10:20:55 +11:00

Compare commits

...

12 Commits

Author SHA1 Message Date
Virgil Dupras
9fcfebd84c forth: Forth-ify "WS?" 2020-03-28 13:18:43 -04:00
Virgil Dupras
a17da42021 forth: remove unused (fbr) and (bbr) 2020-03-28 13:12:07 -04:00
Virgil Dupras
c1693c6256 forth: Forth-ify "TOWORD" 2020-03-28 13:02:04 -04:00
Virgil Dupras
8b7947bc6a forth: Forth-ify "WORD" 2020-03-28 12:55:22 -04:00
Virgil Dupras
6e3b47f4a4 forth: Replace "(fbr)" and "(bbr)" words by "(br)"
I can't get rid of "(fbr)" and "(bbr)" just yet, but soon...
2020-03-28 11:31:16 -04:00
Virgil Dupras
758ec025dc forth: Forth-ify "LITN" 2020-03-28 10:38:05 -04:00
Virgil Dupras
1227ee7155 forth: Forth-ify "EMIT" 2020-03-28 10:25:02 -04:00
Virgil Dupras
2db6ebc247 forth: Forth-ify "BYE" 2020-03-28 10:14:27 -04:00
Virgil Dupras
e0eaa8ba63 forth: Forth-ify "ABORT" 2020-03-28 10:11:52 -04:00
Virgil Dupras
8d8e1d93da forth: slightly improve assembler 2020-03-28 09:39:24 -04:00
Virgil Dupras
ab98e9bcd1 forth: Forth-ify "(uflw)" 2020-03-28 09:19:40 -04:00
Virgil Dupras
5471ef02a7 forth: Forth-ify "BOOT" 2020-03-28 09:08:46 -04:00
7 changed files with 208 additions and 331 deletions

View File

@ -2,7 +2,7 @@
stdio port is 0
)
CODE (emit)
CODE EMIT
HL POPqq,
chkPS,
A L LDrr,

Binary file not shown.

View File

@ -11,8 +11,8 @@
: COMPILE ' LITN ['] , , ; IMMEDIATE
: [COMPILE] ' , ; IMMEDIATE
: BEGIN H@ ; IMMEDIATE
: AGAIN COMPILE (bbr) H@ -^ C, ; IMMEDIATE
: UNTIL COMPILE SKIP? COMPILE (bbr) H@ -^ C, ; IMMEDIATE
: AGAIN COMPILE (br) H@ - , ; IMMEDIATE
: UNTIL COMPILE SKIP? COMPILE (br) H@ - , ; IMMEDIATE
: ( BEGIN LIT< ) WORD SCMP NOT UNTIL ; IMMEDIATE
( Hello, hello, krkrkrkr... do you hear me?
Ah, voice at last! Some lines above need comments
@ -23,29 +23,29 @@
that is, only used by their immediate surrondings.
COMPILE: Tough one. Get addr of caller word (example above
(bbr)) and then call LITN on it. )
(br)) and then call LITN on it. )
: +! SWAP OVER @ + SWAP ! ;
: ALLOT HERE +! ;
: IF ( -- a | a: br cell addr )
COMPILE SKIP? ( if true, don't branch )
COMPILE (fbr)
COMPILE (br)
H@ ( push a )
1 ALLOT ( br cell allot )
2 ALLOT ( br cell allot )
; IMMEDIATE
: THEN ( a -- | a: br cell addr )
DUP H@ -^ SWAP ( a-H a )
C!
!
; IMMEDIATE
: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell )
COMPILE (fbr)
1 ALLOT
COMPILE (br)
2 ALLOT
DUP H@ -^ SWAP ( a-H a )
C!
H@ 1 - ( push a. -1 for allot offset )
!
H@ 2 - ( push a. -2 for allot offset )
; IMMEDIATE
: CREATE
@ -73,8 +73,8 @@
the RS )
: LOOP
COMPILE R> 1 LITN COMPILE + COMPILE DUP COMPILE >R
COMPILE I' COMPILE = COMPILE SKIP? COMPILE (bbr)
H@ -^ C,
COMPILE I' COMPILE = COMPILE SKIP? COMPILE (br)
H@ - ,
COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP
; IMMEDIATE

View File

@ -32,17 +32,11 @@
; *** Const ***
; Base of the Return Stack
.equ RS_ADDR 0xf000
; Number of bytes we keep as a padding between HERE and the scratchpad
.equ PADDING 0x20
; Buffer where WORD copies its read word to.
.equ WORD_BUFSIZE 0x20
; Allocated space for sysvars (see comment above SYSVCNT)
.equ SYSV_BUFSIZE 0x10
; Flags for the "flag field" of the word structure
; IMMEDIATE word
.equ FLAG_IMMED 7
; *** Variables ***
.equ INITIAL_SP RAMSTART
; wordref of the last entry of the dict.
@ -64,10 +58,6 @@
; interface in Forth, which we plug in during init. If "(c<)" exists in the
; dict, CINPTR is set to it. Otherwise, we set KEY
.equ CINPTR @+2
; Pointer to (emit) word
.equ EMITPTR @+2
; Pointer to (print) word
.equ PRINTPTR @+2
.equ WORDBUF @+2
; Sys Vars are variables with their value living in the system RAM segment. We
; need this mechanisms for core Forth source needing variables. Because core
@ -125,10 +115,13 @@ JUMPTBL:
jp nativeWord
jp next
jp chkPS
; 24
NUMBER:
.dw numberWord
LIT:
.dw litWord
.dw INITIAL_SP
.dw WORDBUF
; *** Code ***
forthMain:
@ -138,7 +131,7 @@ forthMain:
; ourselves a nice 6 bytes buffer. 6 bytes because we seldom have words
; requiring more than 3 items from the stack. Then, at each "exit" call
; we check for stack underflow.
push af \ push af \ push af
ld sp, 0xfffa
ld (INITIAL_SP), sp
ld ix, RS_ADDR
; LATEST is a label to the latest entry of the dict. This can be
@ -152,14 +145,6 @@ forthMain:
ld hl, .parseName
call find
ld (PARSEPTR), de
; Set up EMITPTR
ld hl, .emitName
call find
ld (EMITPTR), de
; Set up PRINTPTR
ld hl, .printName
call find
ld (PRINTPTR), de
; Set up CINPTR
; do we have a (c<) impl?
ld hl, .cinName
@ -173,30 +158,19 @@ forthMain:
; Set up SYSVNXT
ld hl, SYSVBUF
ld (SYSVNXT), hl
ld hl, BEGIN
push hl
ld hl, .bootName
call find
push de
jp EXECUTE+2
.parseName:
.db "(parse)", 0
.cinName:
.db "(c<)", 0
.emitName:
.db "(emit)", 0
.printName:
.db "(print)", 0
.keyName:
.db "KEY", 0
BEGIN:
.dw compiledWord
.dw LIT
.db "(c<$)", 0
.dw FIND_
.dw NOT
.dw CSKIP
.dw EXECUTE
.dw INTERPRET
.bootName:
.db "BOOT", 0
INTERPRET:
.dw compiledWord
@ -206,8 +180,11 @@ INTERPRET:
.dw DROP
.dw EXECUTE
.fill 13
.fill 56
; STABLE ABI
; Offset: 00cd
.out $
; *** Collapse OS lib copy ***
; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
; Forth and the concept of ASM libs will become obsolete. To facilitate this
@ -671,61 +648,83 @@ QUIT:
ld ix, RS_ADDR
jp next
.db "ABORT"
.dw $-QUIT
.db 5
ABORT:
.dw compiledWord
.dw .private
.dw QUIT
abortUnderflow:
ld hl, .name
call find
push de
jp EXECUTE+2
.name:
.db "(uflw)", 0
.private:
.db "(br)"
.dw $-QUIT
.db 4
BR:
.dw nativeWord
; Reinitialize PS
ld sp, (INITIAL_SP)
ld hl, (IP)
ld e, (hl)
inc hl
ld d, (hl)
dec hl
add hl, de
ld (IP), hl
jp next
abortUnderflow:
ld hl, .word
push hl
jp EXECUTE+2
.word:
.dw compiledWord
.dw LIT
.db "stack underfl", 0
.dw NUMBER
.dw PRINTPTR
.dw FETCH
.dw EXECUTE
.dw ABORT
; Skip the compword where HL is currently pointing. If it's a regular word,
; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
; to after null-termination.
.db "SKIP?"
.dw $-BR
.db 5
CSKIP:
.dw nativeWord
pop hl
call chkPS
ld a, h
or l
jp z, next ; False, do nothing.
ld hl, (IP)
ld de, NUMBER
call .HLPointsDE
jr z, .isNum
ld de, BR
call .HLPointsDE
jr z, .isNum
ld de, LIT
call .HLPointsDE
jr nz, .isWord
; We have a literal
inc hl \ inc hl
call strskip
inc hl ; byte after word termination
jr .end
.isNum:
; skip by 4
inc hl
inc hl
; continue to isWord
.isWord:
; skip by 2
inc hl \ inc hl
.end:
ld (IP), hl
jp next
.db "BYE"
.dw $-ABORT
.db 3
BYE:
.dw nativeWord
halt
; Sets Z if (HL) == E and (HL+1) == D
.HLPointsDE:
ld a, (hl)
cp e
ret nz ; no
inc hl
ld a, (hl)
dec hl
cp d ; Z has our answer
ret
; STABLE ABI
; Offset: 02aa
.out $
; ( c -- )
.db "EMIT"
.dw $-BYE
.db 4
EMIT:
.dw compiledWord
.dw NUMBER
.dw EMITPTR
.dw FETCH
.dw EXECUTE
.dw EXIT
.fill 71
.fill 45
.db ","
.dw $-EMIT
.dw $-CSKIP
.db 1
WR:
.dw nativeWord
@ -781,25 +780,10 @@ DOES:
jp EXIT+2
.fill 51
; ( n -- )
.db "LITN"
.dw $-DOES
.db 4
LITN:
.dw nativeWord
ld hl, (HERE)
ld de, NUMBER
call DEinHL
pop de ; number from stack
call chkPS
call DEinHL
ld (HERE), hl
jp next
.fill 82
.db "SCPY"
.dw $-LITN
.dw $-DOES
.db 4
SCPY:
.dw nativeWord
@ -846,27 +830,10 @@ CIN:
.dw EXIT
; ( c -- f )
; 33 CMP 1 + NOT
; The NOT is to normalize the negative/positive numbers to 1 or 0.
; Hadn't we wanted to normalize, we'd have written:
; 32 CMP 1 -
.db "WS?"
.dw $-CIN
.db 3
ISWS:
.dw compiledWord
.dw NUMBER
.dw 33
.dw CMP
.dw NUMBER
.dw 1
.dw PLUS
.dw NOT
.dw EXIT
.fill 24
.db "NOT"
.dw $-ISWS
.dw $-CIN
.db 3
NOT:
.dw nativeWord
@ -882,78 +849,11 @@ NOT:
push hl
jp next
; ( -- c )
; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
.db "TOWORD"
.dw $-NOT
.db 6
TOWORD:
.dw compiledWord
.dw CIN
.dw DUP
.dw ISWS
.dw CSKIP
.dw EXIT
.dw DROP
.dw TOWORD
.dw EXIT
; Read word from C<, copy to WORDBUF, null-terminate, and return, make
; HL point to WORDBUF.
.db "WORD"
.dw $-TOWORD
.db 4
; STABLE ABI
; Offset: 04f7
.out $
WORD:
.dw compiledWord
.dw NUMBER ; ( a )
.dw WORDBUF
.dw TOWORD ; ( a c )
; branch mark
.dw OVER ; ( a c a )
.dw STORE ; ( a )
.dw NUMBER ; ( a 1 )
.dw 1
.dw PLUS ; ( a+1 )
.dw CIN ; ( a c )
.dw DUP ; ( a c c )
.dw ISWS ; ( a c f )
.dw CSKIP ; ( a c )
.dw BBR
.db 20 ; here - mark
; at this point, we have ( a WS )
.dw DROP
.dw NUMBER
.dw 0
.dw SWAP ; ( 0 a )
.dw STORE ; ()
.dw NUMBER
.dw WORDBUF
.dw EXIT
.wcpy:
.dw nativeWord
ld de, WORDBUF
push de ; we already have our result
.loop:
ld a, (hl)
cp ' '+1
jr c, .loopend
ld (de), a
inc hl
inc de
jr .loop
.loopend:
; null-terminate the string.
xor a
ld (de), a
jp next
.fill 100
.db "(parsed)"
.dw $-WORD
.dw $-NOT
.db 8
PARSED:
.dw nativeWord
@ -1143,104 +1043,6 @@ CMP:
push bc
jp next
; Skip the compword where HL is currently pointing. If it's a regular word,
; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
; to after null-termination.
.db "SKIP?"
.db "_bend"
.dw $-CMP
.db 5
; STABLE ABI
; Offset: 06ee
.out $
CSKIP:
.dw nativeWord
pop hl
call chkPS
ld a, h
or l
jp z, next ; False, do nothing.
ld hl, (IP)
ld de, NUMBER
call .HLPointsDE
jr z, .isNum
ld de, FBR
call .HLPointsDE
jr z, .isBranch
ld de, BBR
call .HLPointsDE
jr z, .isBranch
ld de, LIT
call .HLPointsDE
jr nz, .isWord
; We have a literal
inc hl \ inc hl
call strskip
inc hl ; byte after word termination
jr .end
.isNum:
; skip by 4
inc hl
; continue to isBranch
.isBranch:
; skip by 3
inc hl
; continue to isWord
.isWord:
; skip by 2
inc hl \ inc hl
.end:
ld (IP), hl
jp next
; Sets Z if (HL) == E and (HL+1) == D
.HLPointsDE:
ld a, (hl)
cp e
ret nz ; no
inc hl
ld a, (hl)
dec hl
cp d ; Z has our answer
ret
; This word's atom is followed by 1b *relative* offset (to the cell's addr) to
; where to branch to. For example, The branching cell of "IF THEN" would
; contain 3. Add this value to RS.
.db "(fbr)"
.dw $-CSKIP
.db 5
; STABLE ABI
; Offset: 073e
.out $
FBR:
.dw nativeWord
push de
ld hl, (IP)
ld a, (hl)
call addHL
ld (IP), hl
pop de
jp next
.db "(bbr)"
.dw $-FBR
.db 5
; STABLE ABI
; Offset: 0757
.out $
BBR:
.dw nativeWord
ld hl, (IP)
ld d, 0
ld e, (hl)
or a ; clear carry
sbc hl, de
ld (IP), hl
jp next
; To allow dict binaries to "hook themselves up", we always end such binary
; with a dummy, *empty* entry. Therefore, we can have a predictable place for
; getting a prev label.
.db "_bend"
.dw $-BBR
.db 5

View File

@ -49,24 +49,12 @@
, ( write! )
; IMMEDIATE
: INTERPRET
BEGIN
WORD
(find)
IF
1 FLAGS !
EXECUTE
0 FLAGS !
ELSE
(parse*) @ EXECUTE
THEN
AGAIN
;
: ABORT _c (resSP) QUIT ;
( This is only the "early parser" in earlier stages. No need
for an abort message )
: (parse)
(parsed) SKIP? ABORT
(parsed) SKIP? _c ABORT
;
( a -- )
@ -76,19 +64,60 @@
_c C@ ( a c )
( exit if null )
DUP NOT IF DROP DROP EXIT THEN
EMIT ( a )
_c EMIT ( a )
1 + ( a+1 )
AGAIN
;
: (uflw)
LIT< stack-underflow _c (print) _c ABORT
;
: C,
HERE @ _c C!
HERE @ 1 + HERE !
;
( The NOT is to normalize the negative/positive numbers to 1
or 0. Hadn't we wanted to normalize, we'd have written:
32 CMP 1 - )
: WS? 33 CMP 1 + NOT ;
: TOWORD
BEGIN
C< DUP _c WS? NOT IF EXIT THEN DROP
AGAIN
;
( Read word from C<, copy to WORDBUF, null-terminate, and
return, make HL point to WORDBUF. )
: WORD
( JTBL+30 == WORDBUF )
[ JTBL 30 + @ LITN ] ( a )
_c TOWORD ( a c )
BEGIN
( We take advantage of the fact that char MSB is
always zero to pre-write our null-termination )
OVER ! ( a )
1 + ( a+1 )
C< ( a c )
DUP _c WS?
UNTIL
( a this point, PS is: a WS )
( null-termination is already written )
DROP DROP
[ JTBL 30 + @ LITN ]
;
: LITN
( JTBL+24 == NUMBER )
JTBL 24 + ,
,
;
: (entry)
HERE @ ( h )
WORD ( h s )
_c WORD ( h s )
SCPY ( h )
( Adjust HERE -1 because SCPY copies the null )
HERE @ 1 _c - ( h h' )
@ -101,21 +130,41 @@
HERE @ CURRENT !
;
: INTERPRET
BEGIN
_c WORD
(find)
IF
1 FLAGS !
EXECUTE
0 FLAGS !
ELSE
(parse*) @ EXECUTE
THEN
AGAIN
;
: BOOT
LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN
_c INTERPRET
;
( : and ; have to be defined last because it can't be
executed now also, they can't have their real name
right away )
: X
_c (entry)
( JTBL+6 == compiledWord )
[ JTBL 6 + LITN ] ,
( We cannot use LITN as IMMEDIATE because of bootstrapping
issues. JTBL+24 == NUMBER JTBL+6 == compiledWord )
[ JTBL 24 + , JTBL 6 + , ] ,
BEGIN
WORD
_c WORD
(find)
( is word )
IF DUP _c IMMED? IF EXECUTE ELSE , THEN
( maybe number )
ELSE (parse*) @ EXECUTE LITN THEN
ELSE (parse*) @ EXECUTE _c LITN THEN
AGAIN
; IMMEDIATE

View File

@ -2,8 +2,7 @@
( Splits word into msb/lsb, lsb being on TOS )
: SPLITB
DUP 0x100 /
SWAP 0xff AND
256 /MOD SWAP
;
( To debug, change C, to .X )
@ -33,6 +32,9 @@
: IY+ _iy+- ;
: IY- 0 -^ _iy+- ;
: <<3 8 * ;
: <<4 16 * ;
( -- )
: OP1 CREATE C, DOES> C@ A, ;
0x76 OP1 HALT,
@ -49,7 +51,7 @@
DOES>
C@ ( r op )
SWAP ( op r )
8 * ( op r<<3 )
<<3 ( op r<<3 )
OR A,
;
0x04 OP1r INCr,
@ -73,7 +75,7 @@
DOES>
C@ ( qq op )
SWAP ( op qq )
16 * ( op qq<<4 )
<<4 ( op qq<<4 )
OR A,
;
0xc5 OP1qq PUSHqq,
@ -85,7 +87,7 @@
: _1rr
C@ ( rd rr op )
ROT ( rr op rd )
8 * ( rr op rd<<3 )
<<3 ( rr op rd<<3 )
OR OR A,
;
@ -126,7 +128,7 @@
DOES>
C@ ( r n op )
ROT ( n op r )
8 * ( n op r<<3 )
<<3 ( n op r<<3 )
OR A, A,
;
0x06 OP2rn LDrn,
@ -138,7 +140,7 @@
0xcb A,
C@ ( b r op )
ROT ( r op b )
8 * ( r op b<<3 )
<<3 ( r op b<<3 )
OR OR A,
;
0xc0 OP2br SETbr,
@ -166,9 +168,9 @@
: OP2r
CREATE ,
DOES>
@ 256 /MOD ( r lsb msb )
@ SPLITB SWAP ( r lsb msb )
A, ( r lsb )
SWAP 8 * ( lsb r<<3 )
SWAP <<3 ( lsb r<<3 )
OR A,
;
0xed41 OP2r OUT(C)r,
@ -180,7 +182,7 @@
DOES>
0xed A,
C@ SWAP ( op ss )
16 * ( op ss<< 4 )
<<4 ( op ss<< 4 )
OR A,
;
0x4a OP2ss ADCHLss,
@ -192,7 +194,7 @@
DOES>
C@ ( dd nn op )
ROT ( nn op dd )
16 * ( nn op dd<<4 )
<<4 ( nn op dd<<4 )
OR A,
SPLITB A, A,
;
@ -223,6 +225,21 @@
0x10 OPJR DJNZe,
( Specials )
( dd nn -- )
: LDdd(nn),
0xed A,
SWAP <<4 0x4b OR A,
SPLITB A, A,
;
( nn dd -- )
: LD(nn)dd,
0xed A,
<<4 0x43 OR A,
SPLITB A, A,
;
( JTBL+18 == next )
: JPNEXT, [ JTBL 18 + LITN ] JPnn, ;

View File

@ -245,3 +245,12 @@ CODE IMMED?
( notset )
DE PUSHqq,
;CODE
CODE BYE
HALT,
;CODE
CODE (resSP)
( INITIAL_SP == JTBL+28 )
SP JTBL 28 + @ LDdd(nn),
;CODE