collapseos/forth/boot.z80

( Configuration words: RAMSTART, RS_ADDR )
H@ 256 /MOD 2 PC! 2 PC!

( RESERVED REGISTERS

  At all times, IX points to RSP TOS and IY is IP. SP points
  to PSP TOS, but you can still use the stack in native code.
  you just have to make sure you've restored it before "next".

  STABLE ABI
  Those jumps below are supposed to stay at these offsets,
  always. If they change bootstrap binaries have to be
  adjusted because they rely on them. Those entries are
  referenced directly by their offset in Forth code with a
  comment indicating what that number refers to.
)

H@ ORG !

0 JPnn,           ( 00, main )
0 JPnn,           ( 03, find )
NOP, NOP,         ( 06, unused )
NOP, NOP,         ( 08, LATEST )
NOP,              ( 0a, unused )
0 JPnn,           ( 0b, cellWord )
0 JPnn,           ( 0e, compiledWord )
0 JPnn,           ( 11, pushRS )
0 JPnn,           ( 14, popRS )
EXDEHL, JP(HL), NOP, ( 17, nativeWord )
0 JPnn,           ( 1a, next )
0 JPnn,           ( 1d, chkPS )
NOP, NOP,         ( 20, numberWord )
NOP, NOP,         ( 22, litWord )
NOP, NOP,         ( 24, addrWord )
NOP, NOP,         ( 26, unused )
RAMSTART 0x4e + JPnn, ( 28, RST 28 )
0 JPnn,           ( 2b, doesWord )
NOP, NOP,         ( 2e, unused )
RAMSTART 0x4e + JPnn, ( RST 30 )
0 JPnn,           ( 33, execute )
NOP, NOP,         ( unused )
RAMSTART 0x4e + JPnn, ( RST 38 )

( BOOT DICT
  There are only 3 words in the boot dict, but these words'
  offset need to be stable, so they're part of the "stable
  ABI"
)
'E' A, 'X' A, 'I' A, 'T' A,
0 A,,   ( prev )
4 A,
H@ XCURRENT !        ( set current tip of dict, 0x42 )
    0x17 A,         ( nativeWord )
    0x14 CALLnn,    ( popRS )
    HL PUSHqq, IY POPqq, ( --> IP )
    JPNEXT,

CODE (br)            ( 0x53 )
L2 BSET ( used in CBR )
    E 0 IY+ LDrIXY,
    D 1 IY+ LDrIXY,
    DE ADDIYss,
    JPNEXT,

CODE (?br)           ( 0x67 )
    HL POPqq,
    chkPS,
    A H LDrr,
    L ORr,
    JRZ, L2 BWR ( BR + 2. False, branch )
    ( True, skip next 2 bytes and don't branch )
    IY INCss,
    IY INCss,
    JPNEXT,

( END OF STABLE ABI )

( We want numberWord and litWord routine to be below the 0x100
  offset so that we can reduce the size of the routine field
  in words to 1 byte. )
( addrWord is the exact same thing as a numberWord except that
  it is treated differently by meta-tools. See notes.txt )
PC ORG @ 0x20 + ! ( numberWord )
PC ORG @ 0x24 + ! ( addrWord )
( This is not a word, but a number literal. This works a bit
  differently than others: PF means nothing and the actual
  number is placed next to the numberWord reference in the
  compiled word list. What we need to do to fetch that number
  is to play with the IP.
)
    E 0 IY+ LDrIXY,
    D 1 IY+ LDrIXY,
    IY INCss,
    IY INCss,
    DE PUSHqq,
    JPNEXT,

PC ORG @ 0x22 + ! ( litWord )
( Similarly to numberWord, this is not a real word, but a
  string literal. Instead of being followed by a 2 bytes
  number, it's followed by a null-terminated string. When
  called, puts the string's address on PS )
    IY PUSHqq, HL POPqq, ( <-- IP )
    HL PUSHqq,
    ( skip to null char )
    A XORr, ( look for null )
    B A LDrr,
    C A LDrr,
    CPIR,
	( CPIR advances HL regardless of comparison, so goes one
      char after NULL. This is good, because that's what we
      want... )
    HL PUSHqq, IY POPqq, ( --> IP )
    JPNEXT,

( Name of BOOT word )
L1 BSET
'B' A, 'O' A, 'O' A, 'T' A, 0 A,

PC ORG @ 1 + ! ( main )
( STACK OVERFLOW PROTECTION:
  To avoid having to check for stack underflow after each pop
  operation (which can end up being prohibitive in terms of
  costs), we give ourselves a nice 6 bytes buffer. 6 bytes
  because we seldom have words requiring more than 3 items
  from the stack. Then, at each "exit" call we check for
  stack underflow.
)
    SP 0xfffa LDddnn,
    RAMSTART SP LD(nn)dd, ( RAM+00 == INITIAL_SP )
    IX RS_ADDR LDddnn,
( HERE begins at RAMEND )
    HL RAMSTART 0x80 + LDddnn,
    RAMSTART 0x04 + LD(nn)HL, ( RAM+04 == HERE )
( LATEST is a label to the latest entry of the dict. It is
  written at offset 0x08 by the process or person building
  Forth. )
    0x08 LDHL(nn),
    RAMSTART 0x02 + LD(nn)HL, ( RAM+02 == CURRENT )
    EXDEHL,
    HL L1 @ LDddnn,
    0x03 CALLnn,        ( 03 == find )
    0x33 JPnn,          ( 33 == execute )

PC ORG @ 4 + ! ( find )
( Find the entry corresponding to word name where (HL) points
  to in dictionary having its tip at DE and sets DE to point
  to that entry. Z if found, NZ if not.
)

    BC PUSHqq,
    HL PUSHqq,
	( First, figure out string len )
    BC 0 LDddnn,
    A XORr,
    CPIR,
	( C has our length, negative, -1 )
    A C LDrr,
    NEG,
    A DECr,
	( special case. zero len? we never find anything. )
    JRZ, L1 FWR ( fail )

    C A LDrr, ( C holds our length )
( Let's do something weird: We'll hold HL by the *tail*.
  Because of our dict structure and because we know our
  lengths, it's easier to compare starting from the end.
  Currently, after CPIR, HL points to char after null. Let's
  adjust. Because the compare loop pre-decrements, instead
  of DECing HL twice, we DEC it once. )
    HL DECss,
BEGIN, ( inner )
    ( DE is a wordref, first step, do our len correspond? )
    HL PUSHqq,          ( --> lvl 1 )
    DE PUSHqq,          ( --> lvl 2 )
    DE DECss,
    LDA(DE),
    0x7f ANDn,          ( remove IMMEDIATE flag )
    C CPr,
    JRNZ, L2 FWR ( loopend )
    ( match, let's compare the string then )
    DE DECss, ( Skip prev field. One less because we )
    DE DECss, ( pre-decrement )
    B C LDrr, ( loop C times )
BEGIN, ( loop )
    ( pre-decrement for easier Z matching )
    DE DECss,
    HL DECss,
    LDA(DE),
    (HL) CPr,
    JRNZ, L3 FWR ( loopend )
    DJNZ, AGAIN, ( loop )
L2 FSET L3 FSET ( loopend )
( At this point, Z is set if we have a match. In all cases,
  we want to pop HL and DE )
    DE POPqq,           ( <-- lvl 2 )
    HL POPqq,           ( <-- lvl 1 )
    JRZ, L2 FWR ( end, match? we're done! )
    ( no match, go to prev and continue )
    HL PUSHqq,          ( --> lvl 1 )
    DE DECss,
    DE DECss,
    DE DECss,           ( prev field )
    DE PUSHqq,          ( --> lvl 2 )
    EXDEHL,
    E (HL) LDrr,
    HL INCss,
    D (HL) LDrr,
    ( DE conains prev offset )
    HL POPqq,           ( <-- lvl 2 )
    ( HL is prev field's addr. Is offset zero? )
    A D LDrr,
    E ORr,
    IFNZ, ( noprev )
        ( get absolute addr from offset )
        ( carry cleared from "or e" )
        DE SBCHLss,
        EXDEHL,             ( result in DE )
    THEN, ( noprev )
    HL POPqq,           ( <-- lvl 1 )
    JRNZ, AGAIN, ( inner, try to match again )
    ( Z set? end of dict, unset Z )
L1 FSET ( fail )
    A XORr,
    A INCr,
L2 FSET ( end )
    HL POPqq,
    BC POPqq,
    RET,

PC ORG @ 0x12 + ! ( pushRS )
    IX INCss,
    IX INCss,
    0 IX+ L LDIXYr,
    1 IX+ H LDIXYr,
    RET,

PC ORG @ 0x15 + ! ( popRS )
    L 0 IX+ LDrIXY,
    H 1 IX+ LDrIXY,
    IX DECss,
    IX DECss,
    RET,

'(' A, 'u' A, 'f' A, 'l' A, 'w' A, ')' A, 0 A,
L2 BSET ( abortUnderflow )
    HL PC 7 - LDddnn,
    DE RAMSTART 0x02 + LDdd(nn),   ( RAM+02 == CURRENT )
    0x03 CALLnn, ( find )
    0x33 JPnn,          ( 33 == execute )


PC ORG @ 0x1e + ! ( chkPS )
    HL PUSHqq,
    RAMSTART LDHL(nn), ( RAM+00 == INITIAL_SP )
( We have the return address for this very call on the stack
  and protected registers. Let's compensate )
    HL DECss,
    HL DECss,
    HL DECss,
    HL DECss,
    SP SUBHLss,
    HL POPqq,
    CNC RETcc,      ( INITIAL_SP >= SP? good )
    JR, L2 BWR ( abortUnderflow )

PC ORG @ 0x1b + ! ( next )
( This routine is jumped to at the end of every word. In it,
  we jump to current IP, but we also take care of increasing
  it by 2 before jumping. )
	( Before we continue: are stacks within bounds? )
    0x1d CALLnn, ( chkPS )
    ( check RS )
    IX PUSHqq, HL POPqq,
    DE RS_ADDR LDddnn,
    DE SUBHLss,
    JRC, L2 BWR ( IX < RS_ADDR? abortUnderflow )
    E 0 IY+ LDrIXY,
    D 1 IY+ LDrIXY,
    IY INCss,
    IY INCss,
    ( continue to execute )

L3 BSET
PC ORG @ 0x34 + ! ( execute )
    ( DE points to wordref )
    EXDEHL,
    E (HL) LDrr,
    D 0 LDrn,
    EXDEHL,
    ( HL points to code pointer )
    DE INCss,
    ( DE points to PFA )
    JP(HL),

L1 BSET
PC ORG @ 0x0f + ! ( compiledWord )
( Execute a list of atoms, which always end with EXIT.
  DE points to that list. What do we do:
  1. Push current IP to RS
  2. Set new IP to the second atom of the list
  3. Execute the first atom of the list. )
    IY PUSHqq, HL POPqq, ( <-- IP )
    0x11 CALLnn,     ( 11 == pushRS )
    EXDEHL,          ( HL points to PFA )
    ( While we increase, dereference into DE for execute call
      later. )
    E (HL) LDrr,
    HL INCss,
    D (HL) LDrr,
    HL INCss,
    HL PUSHqq, IY POPqq, ( --> IP )
    JR, L3 BWR      ( execute )

PC ORG @ 0x0c + ! ( cellWord )
( Pushes PFA directly )
    DE PUSHqq,
    JPNEXT,

PC ORG @ 0x2c + ! ( doesWord )
( The word was spawned from a definition word that has a
  DOES>. PFA+2 (right after the actual cell) is a link to the
  slot right after that DOES>. Therefore, what we need to do
  push the cell addr like a regular cell, then follow the
  linkfrom the PFA, and then continue as a regular
  compiledWord.
)
    DE PUSHqq, ( like a regular cell )
    EXDEHL,
    HL INCss,
    HL INCss,
    E (HL) LDrr,
    HL INCss,
    D (HL) LDrr,
    JR, L1 BWR   ( compiledWord )

( Core words )
  KEY and EMIT are not defined here. There're
  expected to be defined in platform-specific code. )


CODE EXECUTE
    DE POPqq,
    chkPS,
    JR, L3 BWR      ( execute )

( a b c -- b c a )
CODE ROT
    HL POPqq,       ( C )
    DE POPqq,       ( B )
    BC POPqq,       ( A )
    chkPS,
    DE PUSHqq,      ( B )
    HL PUSHqq,      ( C )
    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

CODE PICK
    HL POPqq,
    chkPS,
    ( x2 )
    L SLAr,
    H RLr,
    SP ADDHLss,
    C (HL) LDrr,
    HL INCss,
    B (HL) LDrr,
    ( check PS range before returning )
    EXDEHL,
    RAMSTART LDHL(nn), ( RAM+00 == INITIAL_SP )
    DE SUBHLss,
    CC L2 @ JPccnn,    ( abortUnderflow )
    BC PUSHqq,
;CODE

( this is only a part of ROLL, the other part is performed in
  high level Forth. This receives from PSP the number of bytes
  to copy and then performs A move-by-2 operation from SP.
  This copies SP's TOS and overwrites the last item involved.

  For example, if stack is "1 2 3 4", calling with "4" would
  result in the stack "1 3 4 4". Never call with 0, there is
  no sanity check.
)
CODE (roll)
    HL POPqq,
    B H LDrr,
    C L LDrr,
    SP ADDHLss,
    D H LDrr,
    E L LDrr,
    HL DECss,
    HL DECss,
    LDDR,
;CODE

( a b -- )
CODE 2DROP
    HL POPqq,
    HL POPqq,
    chkPS,
;CODE

CODE S0
    RAMSTART LDHL(nn), ( RAM+00 == INITIAL_SP )
    HL PUSHqq,
;CODE

CODE 'S
    HL 0 LDddnn,
    SP ADDHLss,
    HL PUSHqq,
;CODE

CODE AND
    HL POPqq,
    DE POPqq,
    chkPS,
    A E LDrr,
    L ANDr,
    L A LDrr,
    A D LDrr,
    H ANDr,
    H A LDrr,
    HL PUSHqq,
;CODE

CODE OR
    HL POPqq,
    DE POPqq,
    chkPS,
    A E LDrr,
    L ORr,
    L A LDrr,
    A D LDrr,
    H ORr,
    H A LDrr,
    HL PUSHqq,
;CODE

CODE XOR
    HL POPqq,
    DE POPqq,
    chkPS,
    A E LDrr,
    L XORr,
    L A LDrr,
    A D LDrr,
    H XORr,
    H A LDrr,
    HL PUSHqq,
;CODE

CODE NOT
    HL POPqq,
    chkPS,
    A L LDrr,
    H ORr,
    HL 0 LDddnn,
    IFZ,
        ( false, make 1 )
        HL INCss,
    THEN,
    HL PUSHqq,
;CODE

CODE +
    HL POPqq,
    DE POPqq,
    chkPS,
    DE ADDHLss,
    HL PUSHqq,
;CODE

CODE -
    DE POPqq,
    HL POPqq,
    chkPS,
    DE SUBHLss,
    HL PUSHqq,
;CODE

CODE *
    DE POPqq,
    BC POPqq,
    chkPS,
	( DE * BC -> DE (high) and HL (low) )
    HL 0 LDddnn,
    A 0x10 LDrn,
( loop )
    HL ADDHLss,
    E RLr,
    D RLr,
    JRNC, 4 A, ( noinc )
    BC ADDHLss,
    JRNC, 1 A, ( noinc )
    DE INCss,
( noinc )
    A DECr,
    JRNZ, -14 A, ( loop )
    HL PUSHqq,
;CODE

( Borrowed from http://wikiti.brandonw.net/ )
( Divides AC by DE and places the quotient in AC and the
  remainder in HL )
CODE /MOD
    DE POPqq,
    BC POPqq,
    chkPS,
    A B LDrr,
    B 16 LDrn,
    HL 0 LDddnn,
    BEGIN, ( loop )
        SCF,
        C RLr,
        RLA,
        HL ADCHLss,
        DE SBCHLss,
        IFC,
            DE ADDHLss,
            C DECr,
        THEN,
    DJNZ, AGAIN, ( loop )
    B A LDrr,
    HL PUSHqq,
    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,
    DE PUSHqq,
;CODE

CODE C!
    HL POPqq,
    DE POPqq,
    chkPS,
    (HL) E LDrr,
;CODE

CODE C@
    HL POPqq,
    chkPS,
    L (HL) LDrr,
    H 0 LDrn,
    HL PUSHqq,
;CODE

CODE PC!
    BC POPqq,
    HL POPqq,
    chkPS,
    L OUT(C)r,
;CODE

CODE PC@
    BC POPqq,
    chkPS,
    H 0 LDrn,
    L INr(C),
    HL PUSHqq,
;CODE

CODE I
    L 0 IX+ LDrIXY,
    H 1 IX+ LDrIXY,
    HL PUSHqq,
;CODE

CODE I'
    L 2 IX- LDrIXY,
    H 1 IX- LDrIXY,
    HL PUSHqq,
;CODE

CODE J
    L 4 IX- LDrIXY,
    H 3 IX- LDrIXY,
    HL PUSHqq,
;CODE

CODE >R
    HL POPqq,
    chkPS,
    ( 17 == pushRS )
    17 CALLnn,
;CODE

CODE R>
    ( 20 == popRS )
    20 CALLnn,
    HL PUSHqq,
;CODE

CODE BYE
    HALT,
;CODE

CODE (resSP)
    ( INITIAL_SP == RAM+0 )
    SP RAMSTART LDdd(nn),
;CODE

CODE (resRS)
    IX RS_ADDR LDddnn,
;CODE

CODE S=
    DE  POPqq,
    HL  POPqq,
    chkPS,
    ( pre-push false )
    BC 0 LDddnn,
    BC PUSHqq,
    BEGIN, ( loop )
        LDA(DE),
        (HL) CPr,
        JRNZ, L1 FWR ( not equal? break early to "end".
                       NZ is set. )
        A ORr,   ( if our char is null, stop )
        HL INCss,
        DE INCss,
    JRNZ, AGAIN, ( loop )
    ( success, change false to true )
    HL POPqq,
    HL INCss,
    HL PUSHqq,
L1 FSET ( end )
;CODE

CODE CMP
    HL  POPqq,
    DE  POPqq,
    chkPS,
    DE SUBHLss,
    BC 0 LDddnn,
    IFNZ,
        ( not equal )
        BC INCss,
        IFNC,
            ( < )
            BC DECss,
            BC DECss,
        THEN,
    THEN,
    BC PUSHqq,
;CODE

( cur w -- a f )
CODE _find
    HL POPqq,       ( w )
    DE POPqq,       ( cur )
    chkPS,
    ( 3 == find )
    3 CALLnn,
    IFNZ,
        ( not found )
        HL PUSHqq,
        DE 0 LDddnn,
        DE PUSHqq,
        JPNEXT,
    THEN,
    ( found )
    DE PUSHqq,
    DE 1 LDddnn,
    DE PUSHqq,
;CODE

CODE (im1)
    IM1,
    EI,
;CODE

CODE 0
    HL 0 LDddnn,
    HL PUSHqq,
;CODE

CODE 1
    HL 1 LDddnn,
    HL PUSHqq,
;CODE

CODE -1
    HL -1 LDddnn,
    HL PUSHqq,
;CODE

CODE 1+
    HL POPqq,
    chkPS,
    HL INCss,
    HL PUSHqq,
;CODE

CODE 1-
    HL POPqq,
    chkPS,
    HL DECss,
    HL PUSHqq,
;CODE

CODE 2+
    HL POPqq,
    chkPS,
    HL INCss,
    HL INCss,
    HL PUSHqq,
;CODE

CODE 2-
    HL POPqq,
    chkPS,
    HL DECss,
    HL DECss,
    HL PUSHqq,
;CODE