mirror of
https://github.com/hsoft/collapseos.git
synced 2024-11-02 10:20:55 +11:00
Compare commits
18 Commits
400ef99b54
...
61195a987d
Author | SHA1 | Date | |
---|---|---|---|
|
61195a987d | ||
|
a9cf861cfd | ||
|
f9d45f7f53 | ||
|
e984efe6c3 | ||
|
162ff2c5cb | ||
|
8ef9e7d0da | ||
|
f9c3a0444c | ||
|
49994f09ce | ||
|
8186511727 | ||
|
395eb04fac | ||
|
f6cba4b1cf | ||
|
da9f9f9899 | ||
|
d09ec0d757 | ||
|
cc4700e389 | ||
|
09cd25df29 | ||
|
9cfddea940 | ||
|
a2c258afba | ||
|
7c9d799d93 |
Binary file not shown.
@ -86,9 +86,14 @@
|
||||
|
||||
: (sysv)
|
||||
(entry)
|
||||
( JTBL+0 == sysvarWord )
|
||||
[ JTBL LITN ] ,
|
||||
SYSVNXT @ ,
|
||||
2 SYSVNXT +!
|
||||
( JTBL+42 == SYSVNXT )
|
||||
[ JTBL 42 + @ LITN ] DUP ( a a )
|
||||
( Get new sysv addr )
|
||||
@ , ( a )
|
||||
( increase current sysv counter )
|
||||
2 SWAP +!
|
||||
;
|
||||
|
||||
: ."
|
||||
|
@ -100,6 +100,7 @@ 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
|
||||
|
261
forth/forth.asm
261
forth/forth.asm
@ -122,6 +122,17 @@ 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:
|
||||
@ -141,20 +152,6 @@ 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
|
||||
@ -163,36 +160,14 @@ forthMain:
|
||||
push de
|
||||
jp EXECUTE+2
|
||||
|
||||
.parseName:
|
||||
.db "(parse)", 0
|
||||
.cinName:
|
||||
.db "(c<)", 0
|
||||
.keyName:
|
||||
.db "KEY", 0
|
||||
.bootName:
|
||||
.db "BOOT", 0
|
||||
|
||||
INTERPRET:
|
||||
.dw compiledWord
|
||||
.dw LIT
|
||||
.db "INTERPRET", 0
|
||||
.dw FIND_
|
||||
.dw DROP
|
||||
.dw EXECUTE
|
||||
|
||||
.fill 56
|
||||
.fill 101
|
||||
|
||||
; 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:
|
||||
@ -630,23 +605,7 @@ EXIT:
|
||||
call popRSIP
|
||||
jp next
|
||||
|
||||
; ( 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
|
||||
.fill 30
|
||||
|
||||
abortUnderflow:
|
||||
ld hl, .name
|
||||
@ -657,7 +616,7 @@ abortUnderflow:
|
||||
.db "(uflw)", 0
|
||||
|
||||
.db "(br)"
|
||||
.dw $-QUIT
|
||||
.dw $-EXIT
|
||||
.db 4
|
||||
BR:
|
||||
.dw nativeWord
|
||||
@ -784,24 +743,10 @@ FIND_:
|
||||
push de
|
||||
jp next
|
||||
|
||||
; 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
|
||||
.fill 41
|
||||
|
||||
.db "NOT"
|
||||
.dw $-CIN
|
||||
.dw $-FIND_
|
||||
.db 3
|
||||
NOT:
|
||||
.dw nativeWord
|
||||
@ -841,178 +786,10 @@ PARSED:
|
||||
jp next
|
||||
|
||||
|
||||
.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
|
||||
.fill 224
|
||||
|
||||
.db "_bend"
|
||||
.dw $-CMP
|
||||
.dw $-PARSED
|
||||
.db 5
|
||||
; Offset: 06ee
|
||||
; Offset: 0647
|
||||
.out $
|
||||
|
108
forth/icore.fs
108
forth/icore.fs
@ -17,6 +17,12 @@
|
||||
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,
|
||||
@ -49,7 +55,34 @@
|
||||
, ( write! )
|
||||
; 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
|
||||
for an abort message )
|
||||
@ -60,12 +93,12 @@
|
||||
( a -- )
|
||||
: (print)
|
||||
BEGIN
|
||||
DUP ( a a )
|
||||
_c DUP ( a a )
|
||||
_c C@ ( a c )
|
||||
( exit if null )
|
||||
DUP NOT IF DROP DROP EXIT THEN
|
||||
_c DUP NOT IF _c 2DROP EXIT THEN
|
||||
_c EMIT ( a )
|
||||
1 + ( a+1 )
|
||||
1 _c + ( a+1 )
|
||||
AGAIN
|
||||
;
|
||||
|
||||
@ -73,19 +106,24 @@
|
||||
LIT< stack-underflow _c (print) _c ABORT
|
||||
;
|
||||
|
||||
: C<
|
||||
( JTBL+40 == CINPTR )
|
||||
[ JTBL 40 + @ LITN ] _c @ EXECUTE
|
||||
;
|
||||
|
||||
: C,
|
||||
HERE @ _c C!
|
||||
HERE @ 1 + HERE !
|
||||
_c HERE _c @ _c C!
|
||||
_c HERE _c @ 1 _c + _c HERE _c !
|
||||
;
|
||||
|
||||
( 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 ;
|
||||
: WS? 33 _c CMP 1 _c + NOT ;
|
||||
|
||||
: TOWORD
|
||||
BEGIN
|
||||
C< DUP _c WS? NOT IF EXIT THEN DROP
|
||||
_c C< _c DUP _c WS? NOT IF EXIT THEN _c DROP
|
||||
AGAIN
|
||||
;
|
||||
|
||||
@ -98,36 +136,30 @@
|
||||
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?
|
||||
_c OVER _c ! ( a )
|
||||
1 _c + ( a+1 )
|
||||
_c C< ( a c )
|
||||
_c DUP _c WS?
|
||||
UNTIL
|
||||
( a this point, PS is: a WS )
|
||||
( null-termination is already written )
|
||||
DROP DROP
|
||||
_c 2DROP
|
||||
[ JTBL 30 + @ LITN ]
|
||||
;
|
||||
|
||||
: LITN
|
||||
( JTBL+24 == NUMBER )
|
||||
JTBL 24 + ,
|
||||
,
|
||||
;
|
||||
|
||||
: (entry)
|
||||
HERE @ ( h )
|
||||
_c HERE _c @ ( h )
|
||||
_c WORD ( h s )
|
||||
SCPY ( h )
|
||||
( Adjust HERE -1 because SCPY copies the null )
|
||||
HERE @ 1 _c - ( h h' )
|
||||
DUP HERE ! ( h h' )
|
||||
SWAP _c - ( sz )
|
||||
_c HERE _c @ 1 _c - ( h h' )
|
||||
_c DUP _c HERE _c ! ( h h' )
|
||||
_c SWAP _c - ( sz )
|
||||
( write prev value )
|
||||
HERE @ CURRENT @ _c - ,
|
||||
_c HERE _c @ _c CURRENT _c @ _c - ,
|
||||
( write size )
|
||||
_c C,
|
||||
HERE @ CURRENT !
|
||||
_c HERE _c @ _c CURRENT _c !
|
||||
;
|
||||
|
||||
: INTERPRET
|
||||
@ -135,20 +167,32 @@
|
||||
_c WORD
|
||||
(find)
|
||||
IF
|
||||
1 FLAGS !
|
||||
1 _c FLAGS _c !
|
||||
EXECUTE
|
||||
0 FLAGS !
|
||||
0 _c FLAGS _c !
|
||||
ELSE
|
||||
(parse*) @ EXECUTE
|
||||
_c (parse*) _c @ EXECUTE
|
||||
THEN
|
||||
AGAIN
|
||||
;
|
||||
|
||||
: 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
|
||||
;
|
||||
|
||||
( 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 )
|
||||
@ -162,15 +206,15 @@
|
||||
_c WORD
|
||||
(find)
|
||||
( is word )
|
||||
IF DUP _c IMMED? IF EXECUTE ELSE , THEN
|
||||
IF _c DUP _c IMMED? IF EXECUTE ELSE , THEN
|
||||
( maybe number )
|
||||
ELSE (parse*) @ EXECUTE _c LITN THEN
|
||||
ELSE _c (parse*) _c @ EXECUTE _c LITN THEN
|
||||
AGAIN
|
||||
; IMMEDIATE
|
||||
|
||||
: Y
|
||||
['] EXIT ,
|
||||
_c R> DROP ( exit : )
|
||||
_c R> _c DROP ( exit : )
|
||||
; IMMEDIATE
|
||||
|
||||
( Give ":" and ";" their real name )
|
||||
|
@ -37,6 +37,7 @@
|
||||
|
||||
( -- )
|
||||
: OP1 CREATE C, DOES> C@ A, ;
|
||||
0xeb OP1 EXDEHL,
|
||||
0x76 OP1 HALT,
|
||||
0xc9 OP1 RET,
|
||||
0x17 OP1 RLA,
|
||||
|
@ -31,6 +31,38 @@ 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 )
|
||||
@ -42,6 +74,12 @@ 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
|
||||
@ -111,6 +149,14 @@ CODE XOR
|
||||
HL PUSHqq,
|
||||
;CODE
|
||||
|
||||
CODE +
|
||||
HL POPqq,
|
||||
DE POPqq,
|
||||
chkPS,
|
||||
DE ADDHLss,
|
||||
HL PUSHqq,
|
||||
;CODE
|
||||
|
||||
CODE -
|
||||
DE POPqq,
|
||||
HL POPqq,
|
||||
@ -167,6 +213,25 @@ 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,
|
||||
@ -254,3 +319,31 @@ 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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user