mirror of
https://github.com/hsoft/collapseos.git
synced 2024-12-26 05:48:06 +11:00
b062a9092a
As I wrote in my "Clarify signed-ness" commit, "0 <" is broken. Also, made this unit a bit more compact. The RC2014 stage1 can really use some breathing room...
253 lines
5.9 KiB
Forth
253 lines
5.9 KiB
Forth
( Inner core. This unit represents core definitions that
|
|
happen right after native definitions. Before core.fs.
|
|
|
|
Unlike core.fs and its followers, this unit isn't self-
|
|
sustained. Like native defs it uses the machinery of a
|
|
full Forth interpreter, notably for flow structures.
|
|
|
|
Because of that, it has to obey specific rules:
|
|
|
|
1. It cannot compile a word from higher layers. Using
|
|
immediates is fine though.
|
|
2. If it references a word from this unit or from native
|
|
definitions, these need to be properly offsetted
|
|
because their offset at compile time are not the same
|
|
as their runtime offsets.
|
|
3. Anything they refer to in the boot binary has to be
|
|
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 are *not* offsetted
|
|
|
|
Those rules are mostly met by the "xcomp" unit, which is
|
|
expected to have been loaded prior to icore and redefines
|
|
":" and other defining words. So, in other words, when
|
|
compiling icore, ":" doesn't means what you think it means,
|
|
go look in xcomp.
|
|
)
|
|
|
|
: RAM+
|
|
[ RAMSTART LITN ] +
|
|
;
|
|
|
|
: FLAGS 0x08 RAM+ ;
|
|
: (parse*) 0x0a RAM+ ;
|
|
: HERE 0x04 RAM+ ;
|
|
: CURRENT* 0x51 RAM+ ;
|
|
: CURRENT CURRENT* @ ;
|
|
|
|
( w -- a f )
|
|
: (find) CURRENT @ SWAP _find ;
|
|
|
|
: QUIT
|
|
0 FLAGS ! (resRS)
|
|
LIT< INTERPRET (find) DROP EXECUTE
|
|
;
|
|
|
|
: ABORT (resSP) QUIT ;
|
|
|
|
: = CMP NOT ;
|
|
: < CMP -1 = ;
|
|
: > CMP 1 = ;
|
|
: 0< 32767 > ;
|
|
|
|
( r c -- r f )
|
|
( Parse digit c and accumulate into result r.
|
|
Flag f is 0 when c was a valid digit, 1 when c was WS,
|
|
-1 when c was an invalid digit. )
|
|
: _pdacc
|
|
DUP 0x21 < IF DROP 1 EXIT THEN
|
|
( parse char )
|
|
'0' -
|
|
( if bad, return "r -1" )
|
|
DUP 0< IF DROP -1 EXIT THEN ( bad )
|
|
DUP 9 > IF DROP -1 EXIT THEN ( bad )
|
|
( good, add to running result )
|
|
SWAP 10 * + ( r*10+n )
|
|
0 ( good )
|
|
;
|
|
|
|
: (parsed) ( a -- n f )
|
|
( read first char outside of the loop. it *has* to be
|
|
nonzero. )
|
|
DUP C@ ( a c )
|
|
( special case: do we have a negative? )
|
|
DUP '-' = IF
|
|
( Oh, a negative, let's recurse and reverse )
|
|
DROP 1+ ( a+1 )
|
|
(parsed) ( n f )
|
|
0 ROT ( f 0 n )
|
|
- SWAP EXIT ( 0-n f )
|
|
THEN
|
|
( running result from first char )
|
|
0 SWAP ( a r c )
|
|
_pdacc ( a r f )
|
|
DUP IF
|
|
( first char was not a valid digit )
|
|
2DROP 0 EXIT ( a 0 )
|
|
THEN
|
|
BEGIN ( a r 0 )
|
|
DROP SWAP 1+ ( r a+1 )
|
|
DUP C@ ( r a c )
|
|
ROT SWAP ( a r c )
|
|
_pdacc ( a r f )
|
|
DUP UNTIL
|
|
( a r f -- f is 1 on success, -1 on error, normalize
|
|
to bool. )
|
|
1 = ( a r f )
|
|
( we want "r f" )
|
|
ROT DROP
|
|
;
|
|
|
|
( This is only the "early parser" in earlier stages. No need
|
|
for an abort message )
|
|
: (parse)
|
|
(parsed) NOT IF ABORT THEN
|
|
;
|
|
|
|
: C<
|
|
( 0c == CINPTR )
|
|
0x0c RAM+ @ EXECUTE
|
|
;
|
|
|
|
: ,
|
|
HERE @ !
|
|
HERE @ 2+ HERE !
|
|
;
|
|
|
|
: C,
|
|
HERE @ 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 WS? NOT IF EXIT THEN DROP
|
|
AGAIN
|
|
;
|
|
|
|
( Read word from C<, copy to WORDBUF, null-terminate, and
|
|
return, make HL point to WORDBUF. )
|
|
: WORD
|
|
( 0e == WORDBUF )
|
|
0x0e RAM+ ( a )
|
|
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 WS?
|
|
UNTIL
|
|
( a this point, PS is: a WS )
|
|
( null-termination is already written )
|
|
2DROP
|
|
0x0e RAM+
|
|
;
|
|
|
|
: SCPY
|
|
BEGIN ( a )
|
|
DUP C@ ( a c )
|
|
DUP C, ( a c )
|
|
NOT IF DROP EXIT THEN
|
|
1+ ( a+1 )
|
|
AGAIN
|
|
;
|
|
|
|
: [entry]
|
|
HERE @ ( w h )
|
|
SWAP SCPY ( h )
|
|
( Adjust HERE -1 because SCPY copies the null )
|
|
HERE @ 1- ( h h' )
|
|
DUP HERE ! ( h h' )
|
|
SWAP - ( sz )
|
|
( write prev value )
|
|
HERE @ CURRENT @ - ,
|
|
( write size )
|
|
C,
|
|
HERE @ CURRENT !
|
|
;
|
|
|
|
: (entry) WORD [entry] ;
|
|
|
|
: INTERPRET
|
|
BEGIN
|
|
WORD
|
|
(find)
|
|
IF
|
|
1 FLAGS !
|
|
EXECUTE
|
|
0 FLAGS !
|
|
ELSE
|
|
(parse*) @ EXECUTE
|
|
THEN
|
|
AGAIN
|
|
;
|
|
|
|
( system c< simply reads source from binary, starting at
|
|
LATEST. Convenient way to bootstrap a new system. )
|
|
: (boot<)
|
|
( 2e == BOOT C< PTR )
|
|
0x2e RAM+ @ ( a )
|
|
DUP C@ ( a c )
|
|
SWAP 1 + ( c a+1 )
|
|
0x2e RAM+ ! ( c )
|
|
;
|
|
|
|
: BOOT
|
|
0x02 RAM+ CURRENT* !
|
|
LIT< (parse) (find) DROP (parse*) !
|
|
( 2e == SYSTEM SCRATCHPAD )
|
|
CURRENT @ 0x2e RAM+ !
|
|
( 0c == CINPTR )
|
|
LIT< (boot<) (find) DROP 0x0c RAM+ !
|
|
LIT< INIT (find)
|
|
IF EXECUTE
|
|
ELSE DROP INTERPRET THEN
|
|
;
|
|
|
|
( LITN has to be defined after the last immediate usage of
|
|
it to avoid bootstrapping issues )
|
|
: LITN
|
|
( 32 == NUMBER )
|
|
32 , ,
|
|
;
|
|
|
|
: IMMED? 1- C@ 0x80 AND ;
|
|
|
|
( ';' can't have its name right away because, when created, it
|
|
is not an IMMEDIATE yet and will not be treated properly by
|
|
xcomp. )
|
|
: _
|
|
['] EXIT ,
|
|
R> DROP ( exit : )
|
|
; IMMEDIATE
|
|
|
|
XCURRENT @ ( to PSP )
|
|
|
|
: :
|
|
(entry)
|
|
( We cannot use LITN as IMMEDIATE because of bootstrapping
|
|
issues. Same thing for ",".
|
|
32 == NUMBER 14 == compiledWord )
|
|
[ 32 H@ ! 2 ALLOT 14 H@ ! 2 ALLOT ] C,
|
|
BEGIN
|
|
WORD
|
|
(find)
|
|
( is word )
|
|
IF DUP IMMED? IF EXECUTE ELSE , THEN
|
|
( maybe number )
|
|
ELSE (parse*) @ EXECUTE LITN THEN
|
|
AGAIN
|
|
;
|
|
|
|
( from PSP ) ';' SWAP 4 - C!
|