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

Compare commits

...

18 Commits

Author SHA1 Message Date
Virgil Dupras
61195a987d forth: Forth-ify "HERE", "CURRENT" and "JTBL" 2020-03-30 15:11:23 -04:00
Virgil Dupras
a9cf861cfd forth: Forth-ify "(parse*)" 2020-03-30 14:49:20 -04:00
Virgil Dupras
f9d45f7f53 forth: Forth-ify "FLAGS" 2020-03-30 14:29:21 -04:00
Virgil Dupras
e984efe6c3 forth: Forth-ify SYSVNXT 2020-03-30 14:19:47 -04:00
Virgil Dupras
162ff2c5cb forth: Forth-ify "!" 2020-03-30 14:09:39 -04:00
Virgil Dupras
8ef9e7d0da forth: Forth-ify "@" 2020-03-30 14:05:07 -04:00
Virgil Dupras
f9c3a0444c forth: Forth-ify "DROP" 2020-03-30 13:57:06 -04:00
Virgil Dupras
49994f09ce forth: add word "2DROP" 2020-03-30 13:54:46 -04:00
Virgil Dupras
8186511727 forth: fix bootstrapping issues with "LITN" and "+" 2020-03-30 13:50:53 -04:00
Virgil Dupras
395eb04fac forth: Forth-ify "C<" 2020-03-30 08:37:33 -04:00
Virgil Dupras
f6cba4b1cf forth: Forth-ify "QUIT" 2020-03-30 08:25:22 -04:00
Virgil Dupras
da9f9f9899 forth: melt boot binary 2020-03-30 08:11:16 -04:00
Virgil Dupras
d09ec0d757 forth: Forth-ify "SWAP" 2020-03-30 08:06:11 -04:00
Virgil Dupras
cc4700e389 forth: Forth-ify "DUP" 2020-03-30 08:02:20 -04:00
Virgil Dupras
09cd25df29 forth: Forth-ify "OVER" 2020-03-30 07:58:16 -04:00
Virgil Dupras
9cfddea940 forth: Forth-ify "+" 2020-03-30 07:54:45 -04:00
Virgil Dupras
a2c258afba forth: Forth-ify "CMP"
forth.asm under 1K lines!
2020-03-30 07:52:24 -04:00
Virgil Dupras
7c9d799d93 forth: Forth-ify "SCMP" 2020-03-30 07:48:07 -04:00
7 changed files with 197 additions and 276 deletions

Binary file not shown.

View File

@ -86,9 +86,14 @@
: (sysv) : (sysv)
(entry) (entry)
( JTBL+0 == sysvarWord )
[ JTBL LITN ] , [ JTBL LITN ] ,
SYSVNXT @ , ( JTBL+42 == SYSVNXT )
2 SYSVNXT +! [ JTBL 42 + @ LITN ] DUP ( a a )
( Get new sysv addr )
@ , ( a )
( increase current sysv counter )
2 SWAP +!
; ;
: ." : ."

View File

@ -100,6 +100,7 @@ DUP a -- a a
OVER a b -- a b a OVER a b -- a b a
ROT a b c -- b c a ROT a b c -- b c a
SWAP a b -- b a SWAP a b -- b a
2DROP a a --
2DUP a b -- a b a b 2DUP a b -- a b a b
2OVER a b c d -- a b c d a b 2OVER a b c d -- a b c d a b
2SWAP a b c d -- c d a b 2SWAP a b c d -- c d a b

View File

@ -122,6 +122,17 @@ LIT:
.dw litWord .dw litWord
.dw INITIAL_SP .dw INITIAL_SP
.dw WORDBUF .dw WORDBUF
jp flagsToBC
; 35
jp strcmp
.dw RS_ADDR
.dw CINPTR
.dw SYSVNXT
.dw FLAGS
; 46
.dw PARSEPTR
.dw HERE
.dw CURRENT
; *** Code *** ; *** Code ***
forthMain: forthMain:
@ -141,20 +152,6 @@ forthMain:
ld (CURRENT), hl ld (CURRENT), hl
ld hl, HERE_INITIAL ld hl, HERE_INITIAL
ld (HERE), hl ld (HERE), hl
; Set up PARSEPTR
ld hl, .parseName
call find
ld (PARSEPTR), de
; Set up CINPTR
; do we have a (c<) impl?
ld hl, .cinName
call find
jr z, .skip
; no? then use KEY
ld hl, .keyName
call find
.skip:
ld (CINPTR), de
; Set up SYSVNXT ; Set up SYSVNXT
ld hl, SYSVBUF ld hl, SYSVBUF
ld (SYSVNXT), hl ld (SYSVNXT), hl
@ -163,36 +160,14 @@ forthMain:
push de push de
jp EXECUTE+2 jp EXECUTE+2
.parseName:
.db "(parse)", 0
.cinName:
.db "(c<)", 0
.keyName:
.db "KEY", 0
.bootName: .bootName:
.db "BOOT", 0 .db "BOOT", 0
INTERPRET: .fill 101
.dw compiledWord
.dw LIT
.db "INTERPRET", 0
.dw FIND_
.dw DROP
.dw EXECUTE
.fill 56
; STABLE ABI ; STABLE ABI
; Offset: 00cd ; Offset: 00cd
.out $ .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
; transition, I make, right now, a copy of the routines actually used by Forth's
; native core. This also has the effect of reducing binary size right now and
; give us an idea of Forth's compactness.
; These routines below are copy/paste from apps/lib and stdio.
; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions. ; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions.
; ld must be done little endian, so least significant byte first. ; ld must be done little endian, so least significant byte first.
intoHL: intoHL:
@ -630,23 +605,7 @@ EXIT:
call popRSIP call popRSIP
jp next jp next
; ( R:I -- ) .fill 30
.db "QUIT"
.dw $-EXIT
.db 4
QUIT:
.dw compiledWord
.dw NUMBER
.dw 0
.dw FLAGS_
.dw STORE
.dw .private
.dw INTERPRET
.private:
.dw nativeWord
ld ix, RS_ADDR
jp next
abortUnderflow: abortUnderflow:
ld hl, .name ld hl, .name
@ -657,7 +616,7 @@ abortUnderflow:
.db "(uflw)", 0 .db "(uflw)", 0
.db "(br)" .db "(br)"
.dw $-QUIT .dw $-EXIT
.db 4 .db 4
BR: BR:
.dw nativeWord .dw nativeWord
@ -784,24 +743,10 @@ FIND_:
push de push de
jp next jp next
; This is an indirect word that can be redirected through "CINPTR" .fill 41
; code: it is replaced in readln.fs.
.db "C<"
.dw $-FIND_
.db 2
CIN:
.dw compiledWord
.dw NUMBER
.dw CINPTR
.dw FETCH
.dw EXECUTE
.dw EXIT
.fill 24
.db "NOT" .db "NOT"
.dw $-CIN .dw $-FIND_
.db 3 .db 3
NOT: NOT:
.dw nativeWord .dw nativeWord
@ -841,178 +786,10 @@ PARSED:
jp next jp next
.fill 96 .fill 224
.db "JTBL"
.dw $-PARSED
.db 4
JTBL:
.dw sysvarWord
.dw JUMPTBL
; STABLE ABI (every sysvars)
; Offset: 05ca
.out $
.db "HERE"
.dw $-JTBL
.db 4
HERE_: ; Caution: conflicts with actual variable name
.dw sysvarWord
.dw HERE
.db "CURRENT"
.dw $-HERE_
.db 7
CURRENT_:
.dw sysvarWord
.dw CURRENT
.db "(parse*)"
.dw $-CURRENT_
.db 8
PARSEPTR_:
.dw sysvarWord
.dw PARSEPTR
.db "FLAGS"
.dw $-PARSEPTR_
.db 5
FLAGS_:
.dw sysvarWord
.dw FLAGS
.db "SYSVNXT"
.dw $-FLAGS_
.db 7
SYSVNXT_:
.dw sysvarWord
.dw SYSVNXT
; ( n a -- )
.db "!"
.dw $-SYSVNXT_
.db 1
; STABLE ABI
; Offset: 0610
.out $
STORE:
.dw nativeWord
pop iy
pop hl
call chkPS
ld (iy), l
ld (iy+1), h
jp next
; ( a -- n )
.db "@"
.dw $-STORE
.db 1
FETCH:
.dw nativeWord
pop hl
call chkPS
call intoHL
push hl
jp next
; ( a -- )
.db "DROP"
.dw $-FETCH
.db 4
; STABLE ABI
DROP:
.dw nativeWord
pop hl
jp next
; ( a b -- b a )
.db "SWAP"
.dw $-DROP
.db 4
SWAP:
.dw nativeWord
pop hl
call chkPS
ex (sp), hl
push hl
jp next
; ( a -- a a )
.db "DUP"
.dw $-SWAP
.db 3
DUP:
.dw nativeWord
pop hl
call chkPS
push hl
push hl
jp next
; ( a b -- a b a )
.db "OVER"
.dw $-DUP
.db 4
OVER:
.dw nativeWord
pop hl ; B
pop de ; A
call chkPS
push de
push hl
push de
jp next
.fill 31
; ( a b -- c ) A + B
.db "+"
.dw $-OVER
.db 1
PLUS:
.dw nativeWord
pop hl
pop de
call chkPS
add hl, de
push hl
jp next
.fill 18
; ( a1 a2 -- b )
.db "SCMP"
.dw $-PLUS
.db 4
SCMP:
.dw nativeWord
pop de
pop hl
call chkPS
call strcmp
call flagsToBC
push bc
jp next
; ( n1 n2 -- f )
.db "CMP"
.dw $-SCMP
.db 3
CMP:
.dw nativeWord
pop hl
pop de
call chkPS
or a ; clear carry
sbc hl, de
call flagsToBC
push bc
jp next
.db "_bend" .db "_bend"
.dw $-CMP .dw $-PARSED
.db 5 .db 5
; Offset: 06ee ; Offset: 0647
.out $ .out $

View File

@ -17,6 +17,12 @@
properly stabilized. properly stabilized.
4. Make sure that the words you compile are not overridden 4. Make sure that the words you compile are not overridden
by the full interpreter. by the full interpreter.
5. When using words as immediates, make sure that they're
not defined in icore or, if they are, make sure that
they contain no "_c" references.
All these rules make this unit a bit messy, but this is the
price to pay for the awesomeness of self-bootstrapping.
) )
( When referencing words from native defs or this very unit, ( When referencing words from native defs or this very unit,
@ -49,7 +55,34 @@
, ( write! ) , ( write! )
; IMMEDIATE ; IMMEDIATE
: ABORT _c (resSP) QUIT ; : JTBL 0x08 ;
: FLAGS
( JTBL+44 == FLAGS )
[ JTBL 44 + @ LITN ]
;
: (parse*)
( JTBL+46 == PARSEPTR )
[ JTBL 46 + @ LITN ]
;
: HERE
( JTBL+48 == HERE )
[ JTBL 48 + @ LITN ]
;
: CURRENT
( JTBL+50 == CURRENT )
[ JTBL 50 + @ LITN ]
;
: QUIT
0 _c FLAGS _c ! _c (resRS)
LIT< INTERPRET (find) _c DROP EXECUTE
;
: ABORT _c (resSP) _c QUIT ;
( This is only the "early parser" in earlier stages. No need ( This is only the "early parser" in earlier stages. No need
for an abort message ) for an abort message )
@ -60,12 +93,12 @@
( a -- ) ( a -- )
: (print) : (print)
BEGIN BEGIN
DUP ( a a ) _c DUP ( a a )
_c C@ ( a c ) _c C@ ( a c )
( exit if null ) ( exit if null )
DUP NOT IF DROP DROP EXIT THEN _c DUP NOT IF _c 2DROP EXIT THEN
_c EMIT ( a ) _c EMIT ( a )
1 + ( a+1 ) 1 _c + ( a+1 )
AGAIN AGAIN
; ;
@ -73,19 +106,24 @@
LIT< stack-underflow _c (print) _c ABORT LIT< stack-underflow _c (print) _c ABORT
; ;
: C<
( JTBL+40 == CINPTR )
[ JTBL 40 + @ LITN ] _c @ EXECUTE
;
: C, : C,
HERE @ _c C! _c HERE _c @ _c C!
HERE @ 1 + HERE ! _c HERE _c @ 1 _c + _c HERE _c !
; ;
( The NOT is to normalize the negative/positive numbers to 1 ( The NOT is to normalize the negative/positive numbers to 1
or 0. Hadn't we wanted to normalize, we'd have written: or 0. Hadn't we wanted to normalize, we'd have written:
32 CMP 1 - ) 32 CMP 1 - )
: WS? 33 CMP 1 + NOT ; : WS? 33 _c CMP 1 _c + NOT ;
: TOWORD : TOWORD
BEGIN BEGIN
C< DUP _c WS? NOT IF EXIT THEN DROP _c C< _c DUP _c WS? NOT IF EXIT THEN _c DROP
AGAIN AGAIN
; ;
@ -98,36 +136,30 @@
BEGIN BEGIN
( We take advantage of the fact that char MSB is ( We take advantage of the fact that char MSB is
always zero to pre-write our null-termination ) always zero to pre-write our null-termination )
OVER ! ( a ) _c OVER _c ! ( a )
1 + ( a+1 ) 1 _c + ( a+1 )
C< ( a c ) _c C< ( a c )
DUP _c WS? _c DUP _c WS?
UNTIL UNTIL
( a this point, PS is: a WS ) ( a this point, PS is: a WS )
( null-termination is already written ) ( null-termination is already written )
DROP DROP _c 2DROP
[ JTBL 30 + @ LITN ] [ JTBL 30 + @ LITN ]
; ;
: LITN
( JTBL+24 == NUMBER )
JTBL 24 + ,
,
;
: (entry) : (entry)
HERE @ ( h ) _c HERE _c @ ( h )
_c WORD ( h s ) _c WORD ( h s )
SCPY ( h ) SCPY ( h )
( Adjust HERE -1 because SCPY copies the null ) ( Adjust HERE -1 because SCPY copies the null )
HERE @ 1 _c - ( h h' ) _c HERE _c @ 1 _c - ( h h' )
DUP HERE ! ( h h' ) _c DUP _c HERE _c ! ( h h' )
SWAP _c - ( sz ) _c SWAP _c - ( sz )
( write prev value ) ( write prev value )
HERE @ CURRENT @ _c - , _c HERE _c @ _c CURRENT _c @ _c - ,
( write size ) ( write size )
_c C, _c C,
HERE @ CURRENT ! _c HERE _c @ _c CURRENT _c !
; ;
: INTERPRET : INTERPRET
@ -135,20 +167,32 @@
_c WORD _c WORD
(find) (find)
IF IF
1 FLAGS ! 1 _c FLAGS _c !
EXECUTE EXECUTE
0 FLAGS ! 0 _c FLAGS _c !
ELSE ELSE
(parse*) @ EXECUTE _c (parse*) _c @ EXECUTE
THEN THEN
AGAIN AGAIN
; ;
: BOOT : BOOT
LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN LIT< (parse) (find) _c DROP _c (parse*) _c !
LIT< (c<) (find) NOT IF LIT< KEY (find) _c DROP THEN
( JTBL+40 == CINPTR )
[ JTBL 40 + @ LITN ] _c !
LIT< (c<$) (find) IF EXECUTE ELSE _c DROP THEN
_c INTERPRET _c INTERPRET
; ;
( LITN has to be defined after the last immediate usage of
it to avoid bootstrapping issues )
: LITN
( JTBL+24 == NUMBER )
_c JTBL 24 _c + ,
,
;
( : and ; have to be defined last because it can't be ( : and ; have to be defined last because it can't be
executed now also, they can't have their real name executed now also, they can't have their real name
right away ) right away )
@ -162,15 +206,15 @@
_c WORD _c WORD
(find) (find)
( is word ) ( is word )
IF DUP _c IMMED? IF EXECUTE ELSE , THEN IF _c DUP _c IMMED? IF EXECUTE ELSE , THEN
( maybe number ) ( maybe number )
ELSE (parse*) @ EXECUTE _c LITN THEN ELSE _c (parse*) _c @ EXECUTE _c LITN THEN
AGAIN AGAIN
; IMMEDIATE ; IMMEDIATE
: Y : Y
['] EXIT , ['] EXIT ,
_c R> DROP ( exit : ) _c R> _c DROP ( exit : )
; IMMEDIATE ; IMMEDIATE
( Give ":" and ";" their real name ) ( Give ":" and ";" their real name )

View File

@ -37,6 +37,7 @@
( -- ) ( -- )
: OP1 CREATE C, DOES> C@ A, ; : OP1 CREATE C, DOES> C@ A, ;
0xeb OP1 EXDEHL,
0x76 OP1 HALT, 0x76 OP1 HALT,
0xc9 OP1 RET, 0xc9 OP1 RET,
0x17 OP1 RLA, 0x17 OP1 RLA,

View File

@ -31,6 +31,38 @@ CODE ROT
BC PUSHqq, ( A ) BC PUSHqq, ( A )
;CODE ;CODE
( a -- a a )
CODE DUP
HL POPqq, ( A )
chkPS,
HL PUSHqq, ( A )
HL PUSHqq, ( A )
;CODE
( a -- )
CODE DROP
HL POPqq,
;CODE
( a b -- b a )
CODE SWAP
HL POPqq, ( B )
DE POPqq, ( A )
chkPS,
HL PUSHqq, ( B )
DE PUSHqq, ( A )
;CODE
( a b -- a b a )
CODE OVER
HL POPqq, ( B )
DE POPqq, ( A )
chkPS,
DE PUSHqq, ( A )
HL PUSHqq, ( B )
DE PUSHqq, ( A )
;CODE
( a b -- a b a b ) ( a b -- a b a b )
CODE 2DUP CODE 2DUP
HL POPqq, ( B ) HL POPqq, ( B )
@ -42,6 +74,12 @@ CODE 2DUP
HL PUSHqq, ( B ) HL PUSHqq, ( B )
;CODE ;CODE
( a b -- )
CODE 2DROP
HL POPqq,
HL POPqq,
;CODE
( a b c d -- a b c d a b ) ( a b c d -- a b c d a b )
CODE 2OVER CODE 2OVER
@ -111,6 +149,14 @@ CODE XOR
HL PUSHqq, HL PUSHqq,
;CODE ;CODE
CODE +
HL POPqq,
DE POPqq,
chkPS,
DE ADDHLss,
HL PUSHqq,
;CODE
CODE - CODE -
DE POPqq, DE POPqq,
HL POPqq, HL POPqq,
@ -167,6 +213,25 @@ CODE /MOD
BC PUSHqq, BC PUSHqq,
;CODE ;CODE
CODE !
HL POPqq,
DE POPqq,
chkPS,
(HL) E LDrr,
HL INCss,
(HL) D LDrr,
;CODE
CODE @
HL POPqq,
chkPS,
E (HL) LDrr,
HL INCss,
D (HL) LDrr,
EXDEHL,
HL PUSHqq,
;CODE
CODE C! CODE C!
HL POPqq, HL POPqq,
DE POPqq, DE POPqq,
@ -254,3 +319,31 @@ CODE (resSP)
( INITIAL_SP == JTBL+28 ) ( INITIAL_SP == JTBL+28 )
SP JTBL 28 + @ LDdd(nn), SP JTBL 28 + @ LDdd(nn),
;CODE ;CODE
CODE (resRS)
( RS_ADDR == JTBL+38 )
IX JTBL 38 + @ LDddnn,
;CODE
CODE SCMP
DE POPqq,
HL POPqq,
chkPS,
( JTBL+35 == strcmp )
JTBL 35 + CALLnn,
( JTBL+32 == flagsToBC )
JTBL 32 + CALLnn,
BC PUSHqq,
;CODE
CODE CMP
HL POPqq,
DE POPqq,
chkPS,
A ORr, ( clear carry )
DE SBCHLss,
( JTBL+32 == flagsToBC )
JTBL 32 + CALLnn,
BC PUSHqq,
;CODE