1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-02 12:10:54 +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)
(entry)
( JTBL+0 == sysvarWord )
[ JTBL LITN ] ,
( JTBL+42 == SYSVNXT )
[ JTBL 42 + @ LITN ] DUP ( a a )
( Get new sysv addr )
@ , ( a )
( increase current sysv counter )
2 SWAP +!
SYSVNXT @ ,
2 SYSVNXT +!
;
: ."

View File

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

View File

@ -122,17 +122,6 @@ LIT:
.dw litWord
.dw INITIAL_SP
.dw WORDBUF
jp flagsToBC
; 35
jp strcmp
.dw RS_ADDR
.dw CINPTR
.dw SYSVNXT
.dw FLAGS
; 46
.dw PARSEPTR
.dw HERE
.dw CURRENT
; *** Code ***
forthMain:
@ -152,6 +141,20 @@ forthMain:
ld (CURRENT), hl
ld hl, HERE_INITIAL
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
ld hl, SYSVBUF
ld (SYSVNXT), hl
@ -160,14 +163,36 @@ forthMain:
push de
jp EXECUTE+2
.parseName:
.db "(parse)", 0
.cinName:
.db "(c<)", 0
.keyName:
.db "KEY", 0
.bootName:
.db "BOOT", 0
.fill 101
INTERPRET:
.dw compiledWord
.dw LIT
.db "INTERPRET", 0
.dw FIND_
.dw DROP
.dw EXECUTE
.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
; 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.
; ld must be done little endian, so least significant byte first.
intoHL:
@ -605,7 +630,23 @@ EXIT:
call popRSIP
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:
ld hl, .name
@ -616,7 +657,7 @@ abortUnderflow:
.db "(uflw)", 0
.db "(br)"
.dw $-EXIT
.dw $-QUIT
.db 4
BR:
.dw nativeWord
@ -743,10 +784,24 @@ FIND_:
push de
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"
.dw $-FIND_
.dw $-CIN
.db 3
NOT:
.dw nativeWord
@ -786,10 +841,178 @@ PARSED:
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"
.dw $-PARSED
.dw $-CMP
.db 5
; Offset: 0647
; Offset: 06ee
.out $

View File

@ -17,12 +17,6 @@
properly stabilized.
4. Make sure that the words you compile are not overridden
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,
@ -55,34 +49,7 @@
, ( write! )
; IMMEDIATE
: 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 ;
: ABORT _c (resSP) QUIT ;
( This is only the "early parser" in earlier stages. No need
for an abort message )
@ -93,12 +60,12 @@
( a -- )
: (print)
BEGIN
_c DUP ( a a )
DUP ( a a )
_c C@ ( a c )
( exit if null )
_c DUP NOT IF _c 2DROP EXIT THEN
DUP NOT IF DROP DROP EXIT THEN
_c EMIT ( a )
1 _c + ( a+1 )
1 + ( a+1 )
AGAIN
;
@ -106,24 +73,19 @@
LIT< stack-underflow _c (print) _c ABORT
;
: C<
( JTBL+40 == CINPTR )
[ JTBL 40 + @ LITN ] _c @ EXECUTE
;
: C,
_c HERE _c @ _c C!
_c HERE _c @ 1 _c + _c HERE _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 _c CMP 1 _c + NOT ;
: WS? 33 CMP 1 + NOT ;
: TOWORD
BEGIN
_c C< _c DUP _c WS? NOT IF EXIT THEN _c DROP
C< DUP _c WS? NOT IF EXIT THEN DROP
AGAIN
;
@ -136,30 +98,36 @@
BEGIN
( We take advantage of the fact that char MSB is
always zero to pre-write our null-termination )
_c OVER _c ! ( a )
1 _c + ( a+1 )
_c C< ( a c )
_c DUP _c WS?
OVER ! ( a )
1 + ( a+1 )
C< ( a c )
DUP _c WS?
UNTIL
( a this point, PS is: a WS )
( null-termination is already written )
_c 2DROP
DROP DROP
[ JTBL 30 + @ LITN ]
;
: LITN
( JTBL+24 == NUMBER )
JTBL 24 + ,
,
;
: (entry)
_c HERE _c @ ( h )
HERE @ ( h )
_c WORD ( h s )
SCPY ( h )
( Adjust HERE -1 because SCPY copies the null )
_c HERE _c @ 1 _c - ( h h' )
_c DUP _c HERE _c ! ( h h' )
_c SWAP _c - ( sz )
HERE @ 1 _c - ( h h' )
DUP HERE ! ( h h' )
SWAP _c - ( sz )
( write prev value )
_c HERE _c @ _c CURRENT _c @ _c - ,
HERE @ CURRENT @ _c - ,
( write size )
_c C,
_c HERE _c @ _c CURRENT _c !
HERE @ CURRENT !
;
: INTERPRET
@ -167,32 +135,20 @@
_c WORD
(find)
IF
1 _c FLAGS _c !
1 FLAGS !
EXECUTE
0 _c FLAGS _c !
0 FLAGS !
ELSE
_c (parse*) _c @ EXECUTE
(parse*) @ EXECUTE
THEN
AGAIN
;
: BOOT
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
LIT< (c<$) (find) IF EXECUTE ELSE DROP THEN
_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
executed now also, they can't have their real name
right away )
@ -206,15 +162,15 @@
_c WORD
(find)
( is word )
IF _c DUP _c IMMED? IF EXECUTE ELSE , THEN
IF DUP _c IMMED? IF EXECUTE ELSE , THEN
( maybe number )
ELSE _c (parse*) _c @ EXECUTE _c LITN THEN
ELSE (parse*) @ EXECUTE _c LITN THEN
AGAIN
; IMMEDIATE
: Y
['] EXIT ,
_c R> _c DROP ( exit : )
_c R> DROP ( exit : )
; IMMEDIATE
( Give ":" and ";" their real name )

View File

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

View File

@ -31,38 +31,6 @@ CODE ROT
BC PUSHqq, ( A )
;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 )
CODE 2DUP
HL POPqq, ( B )
@ -74,12 +42,6 @@ CODE 2DUP
HL PUSHqq, ( B )
;CODE
( a b -- )
CODE 2DROP
HL POPqq,
HL POPqq,
;CODE
( a b c d -- a b c d a b )
CODE 2OVER
@ -149,14 +111,6 @@ CODE XOR
HL PUSHqq,
;CODE
CODE +
HL POPqq,
DE POPqq,
chkPS,
DE ADDHLss,
HL PUSHqq,
;CODE
CODE -
DE POPqq,
HL POPqq,
@ -213,25 +167,6 @@ CODE /MOD
BC PUSHqq,
;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!
HL POPqq,
DE POPqq,
@ -319,31 +254,3 @@ CODE (resSP)
( INITIAL_SP == JTBL+28 )
SP JTBL 28 + @ LDdd(nn),
;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