1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-26 17:28:05 +11:00

Compare commits

..

No commits in common. "61195a987d86ea08ddd0688f596def59ed1847fc" and "400ef99b548f5e59e7039b337f4c54cc96f4e0fd" have entirely different histories.

7 changed files with 276 additions and 197 deletions

Binary file not shown.

View File

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

View File

@ -100,7 +100,6 @@ 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,17 +122,6 @@ 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:
@ -152,6 +141,20 @@ 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
@ -160,14 +163,36 @@ 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
.fill 101 INTERPRET:
.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:
@ -605,7 +630,23 @@ EXIT:
call popRSIP call popRSIP
jp next jp next
.fill 30 ; ( R:I -- )
.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
@ -616,7 +657,7 @@ abortUnderflow:
.db "(uflw)", 0 .db "(uflw)", 0
.db "(br)" .db "(br)"
.dw $-EXIT .dw $-QUIT
.db 4 .db 4
BR: BR:
.dw nativeWord .dw nativeWord
@ -743,10 +784,24 @@ FIND_:
push de push de
jp next jp next
.fill 41 ; This is an indirect word that can be redirected through "CINPTR"
; 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 $-FIND_ .dw $-CIN
.db 3 .db 3
NOT: NOT:
.dw nativeWord .dw nativeWord
@ -786,10 +841,178 @@ PARSED:
jp next jp next
.fill 224 .fill 96
.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 $-PARSED .dw $-CMP
.db 5 .db 5
; Offset: 0647 ; Offset: 06ee
.out $ .out $

View File

@ -17,12 +17,6 @@
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,
@ -55,34 +49,7 @@
, ( write! ) , ( write! )
; IMMEDIATE ; IMMEDIATE
: JTBL 0x08 ; : ABORT _c (resSP) QUIT ;
: 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 )
@ -93,12 +60,12 @@
( a -- ) ( a -- )
: (print) : (print)
BEGIN BEGIN
_c DUP ( a a ) DUP ( a a )
_c C@ ( a c ) _c C@ ( a c )
( exit if null ) ( exit if null )
_c DUP NOT IF _c 2DROP EXIT THEN DUP NOT IF DROP DROP EXIT THEN
_c EMIT ( a ) _c EMIT ( a )
1 _c + ( a+1 ) 1 + ( a+1 )
AGAIN AGAIN
; ;
@ -106,24 +73,19 @@
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,
_c HERE _c @ _c C! HERE @ _c C!
_c HERE _c @ 1 _c + _c HERE _c ! HERE @ 1 + HERE !
; ;
( 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 _c CMP 1 _c + NOT ; : WS? 33 CMP 1 + NOT ;
: TOWORD : TOWORD
BEGIN BEGIN
_c C< _c DUP _c WS? NOT IF EXIT THEN _c DROP C< DUP _c WS? NOT IF EXIT THEN DROP
AGAIN AGAIN
; ;
@ -136,30 +98,36 @@
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 )
_c OVER _c ! ( a ) OVER ! ( a )
1 _c + ( a+1 ) 1 + ( a+1 )
_c C< ( a c ) C< ( a c )
_c DUP _c WS? 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 )
_c 2DROP DROP DROP
[ JTBL 30 + @ LITN ] [ JTBL 30 + @ LITN ]
; ;
: LITN
( JTBL+24 == NUMBER )
JTBL 24 + ,
,
;
: (entry) : (entry)
_c HERE _c @ ( h ) HERE @ ( 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 )
_c HERE _c @ 1 _c - ( h h' ) HERE @ 1 _c - ( h h' )
_c DUP _c HERE _c ! ( h h' ) DUP HERE ! ( h h' )
_c SWAP _c - ( sz ) SWAP _c - ( sz )
( write prev value ) ( write prev value )
_c HERE _c @ _c CURRENT _c @ _c - , HERE @ CURRENT @ _c - ,
( write size ) ( write size )
_c C, _c C,
_c HERE _c @ _c CURRENT _c ! HERE @ CURRENT !
; ;
: INTERPRET : INTERPRET
@ -167,32 +135,20 @@
_c WORD _c WORD
(find) (find)
IF IF
1 _c FLAGS _c ! 1 FLAGS !
EXECUTE EXECUTE
0 _c FLAGS _c ! 0 FLAGS !
ELSE ELSE
_c (parse*) _c @ EXECUTE (parse*) @ EXECUTE
THEN THEN
AGAIN AGAIN
; ;
: BOOT : BOOT
LIT< (parse) (find) _c DROP _c (parse*) _c ! LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN
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 )
@ -206,15 +162,15 @@
_c WORD _c WORD
(find) (find)
( is word ) ( is word )
IF _c DUP _c IMMED? IF EXECUTE ELSE , THEN IF DUP _c IMMED? IF EXECUTE ELSE , THEN
( maybe number ) ( maybe number )
ELSE _c (parse*) _c @ EXECUTE _c LITN THEN ELSE (parse*) @ EXECUTE _c LITN THEN
AGAIN AGAIN
; IMMEDIATE ; IMMEDIATE
: Y : Y
['] EXIT , ['] EXIT ,
_c R> _c DROP ( exit : ) _c R> DROP ( exit : )
; IMMEDIATE ; IMMEDIATE
( Give ":" and ";" their real name ) ( Give ":" and ";" their real name )

View File

@ -37,7 +37,6 @@
( -- ) ( -- )
: 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,38 +31,6 @@ 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 )
@ -74,12 +42,6 @@ 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
@ -149,14 +111,6 @@ 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,
@ -213,25 +167,6 @@ 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,
@ -319,31 +254,3 @@ 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