Removed seek words

Removed seek words

: + UM+  DROP   ;
: CELLS  DUP +  ;
: CELL+  2   +  ;
: CELL- -2   +  ;
: CELL   2      ;
: BOOT     0 CELLS ;
: FORTH    4 CELLS ;
: DPL      5 CELLS ;
: SP0      6 CELLS ;
: RP0      7 CELLS ;
: '?KEY    8 CELLS ;
: 'EMIT    9 CELLS ;
: 'EXPECT 10 CELLS ;
: 'TAP    11 CELLS ;
: 'ECHO   12 CELLS ;
: 'PROMPT 13 CELLS ;
: BASE    14 CELLS ;
: tmp     15 CELLS ;
: SPAN    16 CELLS ;
: >IN     17 CELLS ;
: #TIBB   18 CELLS ;
: TIBB    19 CELLS ;
: CSP     20 CELLS ;
: 'EVAL   21 CELLS ;
: 'NUMBER 22 CELLS ;
: HLD     23 CELLS ;
: HANDLER 24 CELLS ;
: CONTEXT 25 CELLS ;
: CURRENT 27 CELLS ;
: CP      29 CELLS ;
: NP      30 CELLS ;
: LAST    31 CELLS ;
: STATE   32 CELLS ;
: SPP     33 CELLS ;
: RPP     34 CELLS ;
: TRUE -1 ;
: FALSE 0 ;
: BL 32 ;
: BS 8 ;
: =IMMED    3 ;
: =WORDLIST 2 ;
: IMMEDIATE =IMMED LAST @ CELL- ! ;
: HERE CP @ ;
: ALLOT CP @ + CP ! ;
: , HERE CELL ALLOT ! ;
: C, HERE 1 ALLOT C! ;
: +! SWAP OVER @ + SWAP ! ;
: COMPILE R> DUP @ , CELL+ >R ;
: STATE? STATE @ ;
: LITERAL COMPILE LIT , ; IMMEDIATE
: [ FALSE STATE ! ; IMMEDIATE
: ] TRUE STATE ! ; IMMEDIATE
: IF COMPILE 0BRANCH HERE 0 , ; IMMEDIATE
: THEN HERE SWAP ! ; IMMEDIATE
: FOR COMPILE >R HERE ; IMMEDIATE
: NEXT COMPILE next , ; IMMEDIATE
: BEGIN HERE ; IMMEDIATE
: AGAIN COMPILE BRANCH , ; IMMEDIATE
: UNTIL COMPILE 0BRANCH , ; IMMEDIATE
: AHEAD COMPILE BRANCH HERE 0 , ; IMMEDIATE
: REPEAT COMPILE BRANCH , HERE SWAP ! ; IMMEDIATE
: AFT DROP COMPILE BRANCH HERE 0 ,  HERE SWAP ; IMMEDIATE
: ELSE COMPILE BRANCH HERE 0 ,  SWAP HERE SWAP !  ; IMMEDIATE
: WHILE COMPILE 0BRANCH HERE 0 , SWAP ; IMMEDIATE
: EXECUTE >R ;
: @EXECUTE @ DUP IF EXECUTE THEN ;
: R@ R> R> DUP >R SWAP >R ;
: #TIB #TIBB @ ;
: TIB TIBB @ ;
: \ #TIB @ >IN ! ; IMMEDIATE
: ROT >R SWAP R> SWAP ;
: -ROT SWAP >R SWAP R> ;
: NIP SWAP DROP ;
: TUCK SWAP OVER ;
: 2>R SWAP R> SWAP >R SWAP >R >R ;
: 2R> R> R> SWAP R> SWAP >R SWAP ;
: 2R@ R> R> R@ SWAP >R SWAP R@ SWAP >R ;
: 2DROP DROP DROP ;
: 2DUP OVER OVER ;
: 2SWAP ROT >R ROT R> ;
: 2OVER >R >R 2DUP R> R> 2SWAP ;
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
: -2ROT 2ROT 2ROT ;
: 2NIP 2SWAP 2DROP ;
: 2TUCK 2SWAP 2OVER ;
: NOT DUP NAND ;
: AND NAND NOT ;
: OR NOT SWAP NOT NAND ;
: NOR OR NOT ;
: XOR 2DUP AND -ROT NOR NOR ;
: XNOR XOR NOT ;
: NEGATE NOT 1 + ;
: - NEGATE + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: D+ >R SWAP >R UM+ R> R> + + ;
: DNEGATE NOT >R NOT 1 UM+ R> + ;
: D- DNEGATE D+ ;
: 2! SWAP OVER ! CELL+ ! ;
: 2@ DUP CELL+ @ SWAP @ ;
: ?DUP DUP IF DUP THEN ;
: S>D DUP 0< ;
: ABS DUP 0< IF NEGATE THEN ;
: DABS DUP 0< IF DNEGATE THEN ;
: U< 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< ;
: U> SWAP U< ;
: = XOR IF FALSE EXIT THEN TRUE ;
: < 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;
: > SWAP < ;
: 0> NEGATE 0< ;
: 0<> IF TRUE EXIT THEN FALSE ;
: 0= 0 = ;
: <> = 0= ;
: D0< SWAP DROP 0< ;
: D0> DNEGATE D0< ;
: D0= OR 0= ;
: D= D- D0= ;
: D< ROT 2DUP XOR IF SWAP 2SWAP 2DROP < ;
: DU< ROT 2DUP XOR IF SWAP 2SWAP THEN THEN 2DROP U< ;
: DMIN 2OVER 2OVER 2SWAP D< IF 2SWAP THEN 2DROP ;
: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
: M+ S>D D+ ;
: M- S>D D- ;
: MIN 2DUP SWAP < IF SWAP THEN DROP ;
: MAX 2DUP < IF SWAP THEN DROP ;
: UMIN 2DUP SWAP U< IF SWAP THEN DROP ;
: UMAX 2DUP U< IF SWAP THEN DROP ;
: WITHIN OVER - >R - R> U< ;
: UM/MOD
    2DUP U<
    IF NEGATE
        15 FOR
            >R DUP UM+
                >R >R DUP UM+
                R> + DUP R> R@ SWAP
            >R UM+
            R> OR
                IF >R DROP 1+ R>
                ELSE DROP
            THEN R>
        NEXT DROP SWAP EXIT
    THEN DROP 2DROP -1 DUP ;
: M/MOD
    DUP 0< DUP >R
        IF NEGATE >R
            DNEGATE R>
        THEN >R DUP 0<
        IF R@ +
        THEN R> UM/MOD
    R>
    IF SWAP NEGATE SWAP THEN ;
: /MOD OVER 0< SWAP M/MOD ;
: MOD /MOD DROP ;
: / /MOD NIP ;
: UM*
    0 SWAP
    15 FOR
        DUP UM+ >R >R
        DUP UM+
        R> +
        R>
        IF >R OVER UM+
            R> +
        THEN
    NEXT
    ROT DROP ;
: * UM* DROP ;
: M*
    2DUP XOR 0< >R
    ABS SWAP ABS UM*
    R> IF DNEGATE THEN ;
: */MOD >R M* R> M/MOD ;
: */ */MOD SWAP DROP ;
: 2* 2 * ;
: 2/ 2 / ;
: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
: D2* 2DUP D+ ;
: DU2/ 2 MU/MOD ROT DROP ;
: D2/ DUP >R 1 AND DU2/ R> 2/ OR ;
: ALIGNED DUP 0 2 UM/MOD DROP DUP IF 2 SWAP - THEN + ;
: parse
    tmp ! OVER >R DUP
    IF
        1- tmp @ BL =
        IF
            FOR BL OVER C@ - 0< NOT
            WHILE 1+
                NEXT R> DROP 0 DUP EXIT
            THEN R>
        THEN
            OVER SWAP
        FOR tmp @ OVER C@ - tmp @ BL =
            IF 0< THEN
        WHILE 1+
        NEXT DUP >R
        ELSE R> DROP DUP 1+ >R
        THEN OVER - R> R> - EXIT
    THEN OVER R> - ;
: PARSE >R TIB >IN @ + #TIB C@ >IN @ - R> parse >IN +! ;
: CHAR BL PARSE DROP C@ ;
: TX! 1 PUTC ;
: EMIT 'EMIT @EXECUTE ;
: TYPE FOR AFT DUP C@ EMIT 1+ THEN NEXT DROP ;
: ?RX 0 GETC ;
: ?KEY '?KEY @EXECUTE ;
: KEY BEGIN ?KEY UNTIL ;
: COUNT DUP 1+ SWAP C@ ;
: CMOVE
    FOR
        AFT
            >R DUP C@ R@ C! 1+ R> 1+
        THEN
    NEXT 2DROP ;
: FILL
    SWAP
    FOR SWAP
        AFT 2DUP C! 1+ THEN
    NEXT 2DROP ;
: -TRAILING
    FOR
        AFT
        BL OVER R@ + C@ <
        IF
            R> 1+ EXIT
        THEN
    THEN
    NEXT 0 ;
: PACK$
    DUP >R
        2DUP C! 1+ 2DUP + 0 SWAP ! SWAP CMOVE
    R> ;
: WORD PARSE HERE PACK$ ;
: TOKEN BL PARSE 31 MIN NP @ OVER - 1- PACK$ ;
: LINK> 3 CELLS - ;
: CODE> 2 CELLS - ;
: TYPE> 1 CELLS - ;
: DATA> CELL+ ;
: SAME?
    FOR AFT
        OVER R@ CELLS + @
        OVER R@ CELLS + @
        - ?DUP
        IF R> DROP EXIT THEN
    THEN
    NEXT 0 ;
: find
    @ BEGIN DUP WHILE
        2DUP C@ SWAP C@ = IF
        2DUP 1+ SWAP COUNT ALIGNED CELL / >R SWAP R>
        SAME? 0= IF
            2DROP SWAP DROP DUP CODE> @ SWAP -1 EXIT
        THEN 2DROP THEN
    LINK> @ REPEAT ;
: ' TOKEN CONTEXT @ find IF DROP ELSE SWAP DROP 0 THEN ;
: ! ! ;
' TX! 'EMIT !
' ?RX '?KEY !
: ['] COMPILE ' ; IMMEDIATE
: POSTPONE ' , ; IMMEDIATE
: [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE
: ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
: :NONAME HERE POSTPONE ] ;
: OVERT LAST @ CURRENT @ ! ;
: $,n
    DUP LAST ! CELL-
    DUP =WORDLIST
    SWAP !
    CELL- DUP HERE
    SWAP !
    CELL- DUP CURRENT @ @
    SWAP !
    CELL- NP ! ;
: : TOKEN $,n POSTPONE ] ;
: ; COMPILE EXIT POSTPONE [ OVERT ; IMMEDIATE
: RECURSE LAST @ CURRENT @ ! ; IMMEDIATE
: doVAR R> ;
: CREATE TOKEN $,n COMPILE doVAR OVERT ;
: DOES LAST @ CODE> @ R> SWAP ! ;
: DOES> COMPILE DOES COMPILE R> ; IMMEDIATE
: CONSTANT CREATE , DOES> @ ;
: VARIABLE CREATE 0 , ;
: 2LITERAL SWAP POSTPONE LITERAL
    POSTPONE LITERAL ; IMMEDIATE
: 2CONSTANT CREATE , , DOES> 2@ ;
: 2VARIABLE CREATE 2 CELLS ALLOT ;
: SPACE BL EMIT ;
: SPACES 0 MAX FOR SPACE NEXT ;
: PAD HERE 80 + ;
: DECIMAL 10 BASE ! ;
: HEX 16 BASE ! ;
: BINARY 2 BASE ! ;
: OCTAL 8 BASE ! ;
DECIMAL
: CHAR- 1- ;
: CHAR+ 1+ ;
: CHARS ;
: >CHAR 127 AND DUP 127 BL WITHIN IF DROP 95 THEN ;
: DIGIT 9 OVER < 7 AND + [CHAR] 0 + ;
: <# PAD HLD ! ;
: HOLD HLD @ CHAR- DUP HLD ! C! ;
: # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
: #S BEGIN # 2DUP OR 0= UNTIL ;
: SIGN 0< IF [CHAR] - HOLD THEN ;
: #> 2DROP HLD @ PAD OVER - ;
: S.R OVER - SPACES TYPE ;
: D.R >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
: U.R 0 SWAP D.R ;
: .R >R S>D R> D.R ;
: D. 0 D.R SPACE ;
: U. 0 D. ;
: . BASE @ 10 XOR IF U. EXIT THEN S>D D. ;
: ? @ . ;
: DU.R >R <# #S #> R> S.R ;
: DU. DU.R SPACE ;
: do$ R> R@ R> COUNT + ALIGNED >R SWAP >R ;
: ."| do$ COUNT TYPE ;
: $," [CHAR] " WORD COUNT + ALIGNED CP ! ;
: ." COMPILE ."| $," ; IMMEDIATE
: .( [CHAR] ) PARSE TYPE ; IMMEDIATE
: $"| do$ ;
: $" COMPILE $"| $," ; IMMEDIATE
: s" [CHAR] " PARSE HERE PACK$ ;
: CR 10 EMIT ;
: TAP OVER C! 1+ ;
: KTAP
    10 XOR
    IF
        BL TAP EXIT
    THEN
    NIP DUP ;
: ACCEPT
    OVER + OVER
    BEGIN
        2DUP XOR
    WHILE
        KEY
        DUP BL - 95 U<
        IF TAP ELSE KTAP THEN
    REPEAT DROP OVER - ;
: EXPECT ACCEPT SPAN ! DROP ;
: QUERY TIB 80 ACCEPT #TIB C! DROP 0 >IN ! ;
: DIGIT?
    >R [CHAR] 0 -
    9 OVER <
    IF 7 - DUP 10 < OR THEN
    DUP R> U< ;
: /STRING DUP >R - SWAP R> + SWAP ;
: >NUMBER
    BEGIN DUP
    WHILE >R DUP >R C@ BASE @ DIGIT?
    WHILE SWAP BASE @ UM* DROP ROT
    BASE @ UM* D+ R> CHAR+ R> 1 -
    REPEAT DROP R> R> THEN ;
: NUMBER?
    OVER C@ [CHAR] - = DUP >R IF 1 /STRING THEN
    >R >R 0 DUP R> R> -1 DPL !
    BEGIN >NUMBER DUP
    WHILE OVER C@ [CHAR] . XOR
        IF ROT DROP ROT R> 2DROP FALSE EXIT
    THEN 1 - DPL ! CHAR+ DPL @
    REPEAT 2DROP R> IF DNEGATE THEN TRUE ;
' NUMBER? 'NUMBER !
: $INTERPRET
    CONTEXT @ find
    IF DROP EXECUTE EXIT THEN
    COUNT 'NUMBER @EXECUTE IF
        DPL @ 0< IF DROP THEN EXIT THEN ." ?" TYPE ;
: $COMPILE
    CONTEXT @ find
    IF CELL- @ =IMMED =
        IF EXECUTE ELSE , THEN EXIT
    THEN COUNT 'NUMBER @EXECUTE
    IF
        DPL @ 0<
        IF DROP POSTPONE LITERAL
        ELSE POSTPONE 2LITERAL
        THEN EXIT
    THEN ." ?" TYPE ;
: eval STATE? IF $COMPILE ELSE $INTERPRET THEN ;
' eval 'EVAL !
: EVAL
    BEGIN TOKEN DUP C@ WHILE
        'EVAL @EXECUTE
    REPEAT DROP ;
: OK CR ." OK." SPACE ;
' OK 'PROMPT !
: QUIT
    BEGIN 'PROMPT @EXECUTE QUERY
    EVAL AGAIN ;
: BYE ." Good Bye " CR HALT ;
' QUIT BOOT !
: SP@ SPP @ ;
: DEPTH SP@ SP0 @ - CELL / ;
: PICK CELLS SP@ SWAP - 2 CELLS - @ ;
: .S CR DEPTH FOR AFT R@ PICK . THEN NEXT SPACE ." <SP " CR ;
: WORDS
    CONTEXT @ @ BEGIN DUP WHILE DUP COUNT TYPE LINK>
    @ SPACE REPEAT DROP CR ;

VARIABLE FILE
: OPEN F_OPEN FILE ! ;
: CLOSE FILE @ F_CLOSE ;
: FPUT FILE @ PUTC ;
: FGET FILE @ GETC ;
: FPUTS COUNT FOR AFT DUP C@ FPUT 1+ THEN NEXT DROP ;

: SAVEVM $" eforth.img" $" wb" OPEN 0
    16384 FOR AFT DUP C@ FPUT 1+ THEN NEXT CLOSE DROP ;

SAVEVM

: + UM+  DROP   ;
: CELLS  DUP +  ;
: CELL+  2   +  ;
: CELL- -2   +  ;
: CELL   2      ;
: BOOT     0 CELLS ;
: FORTH    4 CELLS ;
: DPL      5 CELLS ;
: SP0      6 CELLS ;
: RP0      7 CELLS ;
: '?KEY    8 CELLS ;
: 'EMIT    9 CELLS ;
: 'EXPECT 10 CELLS ;
: 'TAP    11 CELLS ;
: 'ECHO   12 CELLS ;
: 'PROMPT 13 CELLS ;
: BASE    14 CELLS ;
: tmp     15 CELLS ;
: SPAN    16 CELLS ;
: >IN     17 CELLS ;
: #TIBB   18 CELLS ;
: TIBB    19 CELLS ;
: CSP     20 CELLS ;
: 'EVAL   21 CELLS ;
: 'NUMBER 22 CELLS ;
: HLD     23 CELLS ;
: HANDLER 24 CELLS ;
: CONTEXT 25 CELLS ;
: CURRENT 27 CELLS ;
: CP      29 CELLS ;
: NP      30 CELLS ;
: LAST    31 CELLS ;
: STATE   32 CELLS ;
: SPP     33 CELLS ;
: RPP     34 CELLS ;
: TRUE -1 ;
: FALSE 0 ;
: BL 32 ;
: BS 8 ;
: =IMMED    3 ;
: =WORDLIST 2 ;
: IMMEDIATE =IMMED LAST @ CELL- ! ;
: HERE CP @ ;
: ALLOT CP @ + CP ! ;
: , HERE CELL ALLOT ! ;
: C, HERE 1 ALLOT C! ;
: +! SWAP OVER @ + SWAP ! ;
: COMPILE R> DUP @ , CELL+ >R ;
: STATE? STATE @ ;
: LITERAL COMPILE LIT , ; IMMEDIATE
: [ FALSE STATE ! ; IMMEDIATE
: ] TRUE STATE ! ; IMMEDIATE
: IF COMPILE 0BRANCH HERE 0 , ; IMMEDIATE
: THEN HERE SWAP ! ; IMMEDIATE
: FOR COMPILE >R HERE ; IMMEDIATE
: NEXT COMPILE next , ; IMMEDIATE
: BEGIN HERE ; IMMEDIATE
: AGAIN COMPILE BRANCH , ; IMMEDIATE
: UNTIL COMPILE 0BRANCH , ; IMMEDIATE
: AHEAD COMPILE BRANCH HERE 0 , ; IMMEDIATE
: REPEAT COMPILE BRANCH , HERE SWAP ! ; IMMEDIATE
: AFT DROP COMPILE BRANCH HERE 0 ,  HERE SWAP ; IMMEDIATE
: ELSE COMPILE BRANCH HERE 0 ,  SWAP HERE SWAP !  ; IMMEDIATE
: WHILE COMPILE 0BRANCH HERE 0 , SWAP ; IMMEDIATE
: EXECUTE >R ;
: @EXECUTE @ DUP IF EXECUTE THEN ;
: R@ R> R> DUP >R SWAP >R ;
: #TIB #TIBB @ ;
: TIB TIBB @ ;
: \ #TIB @ >IN ! ; IMMEDIATE
: ROT >R SWAP R> SWAP ;
: -ROT SWAP >R SWAP R> ;
: NIP SWAP DROP ;
: TUCK SWAP OVER ;
: 2>R SWAP R> SWAP >R SWAP >R >R ;
: 2R> R> R> SWAP R> SWAP >R SWAP ;
: 2R@ R> R> R@ SWAP >R SWAP R@ SWAP >R ;
: 2DROP DROP DROP ;
: 2DUP OVER OVER ;
: 2SWAP ROT >R ROT R> ;
: 2OVER >R >R 2DUP R> R> 2SWAP ;
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
: -2ROT 2ROT 2ROT ;
: 2NIP 2SWAP 2DROP ;
: 2TUCK 2SWAP 2OVER ;
: NOT DUP NAND ;
: AND NAND NOT ;
: OR NOT SWAP NOT NAND ;
: NOR OR NOT ;
: XOR 2DUP AND -ROT NOR NOR ;
: XNOR XOR NOT ;
: NEGATE NOT 1 + ;
: - NEGATE + ;
: 1+ 1 + ;
: 1- 1 - ;
: 2+ 2 + ;
: 2- 2 - ;
: D+ >R SWAP >R UM+ R> R> + + ;
: DNEGATE NOT >R NOT 1 UM+ R> + ;
: D- DNEGATE D+ ;
: 2! SWAP OVER ! CELL+ ! ;
: 2@ DUP CELL+ @ SWAP @ ;
: ?DUP DUP IF DUP THEN ;
: S>D DUP 0< ;
: ABS DUP 0< IF NEGATE THEN ;
: DABS DUP 0< IF DNEGATE THEN ;
: U< 2DUP XOR 0< IF SWAP DROP 0< EXIT THEN - 0< ;
: U> SWAP U< ;
: = XOR IF FALSE EXIT THEN TRUE ;
: < 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;
: > SWAP < ;
: 0> NEGATE 0< ;
: 0<> IF TRUE EXIT THEN FALSE ;
: 0= 0 = ;
: <> = 0= ;
: D0< SWAP DROP 0< ;
: D0> DNEGATE D0< ;
: D0= OR 0= ;
: D= D- D0= ;
: D< ROT 2DUP XOR IF SWAP 2SWAP 2DROP < ;
: DU< ROT 2DUP XOR IF SWAP 2SWAP THEN THEN 2DROP U< ;
: DMIN 2OVER 2OVER 2SWAP D< IF 2SWAP THEN 2DROP ;
: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
: M+ S>D D+ ;
: M- S>D D- ;
: MIN 2DUP SWAP < IF SWAP THEN DROP ;
: MAX 2DUP < IF SWAP THEN DROP ;
: UMIN 2DUP SWAP U< IF SWAP THEN DROP ;
: UMAX 2DUP U< IF SWAP THEN DROP ;
: WITHIN OVER - >R - R> U< ;
: UM/MOD
    2DUP U<
    IF NEGATE
        15 FOR
            >R DUP UM+
                >R >R DUP UM+
                R> + DUP R> R@ SWAP
            >R UM+
            R> OR
                IF >R DROP 1+ R>
                ELSE DROP
            THEN R>
        NEXT DROP SWAP EXIT
    THEN DROP 2DROP -1 DUP ;
: M/MOD
    DUP 0< DUP >R
        IF NEGATE >R
            DNEGATE R>
        THEN >R DUP 0<
        IF R@ +
        THEN R> UM/MOD
    R>
    IF SWAP NEGATE SWAP THEN ;
: /MOD OVER 0< SWAP M/MOD ;
: MOD /MOD DROP ;
: / /MOD NIP ;
: UM*
    0 SWAP
    15 FOR
        DUP UM+ >R >R
        DUP UM+
        R> +
        R>
        IF >R OVER UM+
            R> +
        THEN
    NEXT
    ROT DROP ;
: * UM* DROP ;
: M*
    2DUP XOR 0< >R
    ABS SWAP ABS UM*
    R> IF DNEGATE THEN ;
: */MOD >R M* R> M/MOD ;
: */ */MOD SWAP DROP ;
: 2* 2 * ;
: 2/ 2 / ;
: MU/MOD >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
: D2* 2DUP D+ ;
: DU2/ 2 MU/MOD ROT DROP ;
: D2/ DUP >R 1 AND DU2/ R> 2/ OR ;
: ALIGNED DUP 0 2 UM/MOD DROP DUP IF 2 SWAP - THEN + ;
: parse
    tmp ! OVER >R DUP
    IF
        1- tmp @ BL =
        IF
            FOR BL OVER C@ - 0< NOT
            WHILE 1+
                NEXT R> DROP 0 DUP EXIT
            THEN R>
        THEN
            OVER SWAP
        FOR tmp @ OVER C@ - tmp @ BL =
            IF 0< THEN
        WHILE 1+
        NEXT DUP >R
        ELSE R> DROP DUP 1+ >R
        THEN OVER - R> R> - EXIT
    THEN OVER R> - ;
: PARSE >R TIB >IN @ + #TIB C@ >IN @ - R> parse >IN +! ;
: CHAR BL PARSE DROP C@ ;
: TX! 1 PUTC ;
: EMIT 'EMIT @EXECUTE ;
: TYPE FOR AFT DUP C@ EMIT 1+ THEN NEXT DROP ;
: ?RX 0 GETC ;
: ?KEY '?KEY @EXECUTE ;
: KEY BEGIN ?KEY UNTIL ;
: COUNT DUP 1+ SWAP C@ ;
: CMOVE
    FOR
        AFT
            >R DUP C@ R@ C! 1+ R> 1+
        THEN
    NEXT 2DROP ;
: FILL
    SWAP
    FOR SWAP
        AFT 2DUP C! 1+ THEN
    NEXT 2DROP ;
: -TRAILING
    FOR
        AFT
        BL OVER R@ + C@ <
        IF
            R> 1+ EXIT
        THEN
    THEN
    NEXT 0 ;
: PACK$
    DUP >R
        2DUP C! 1+ 2DUP + 0 SWAP ! SWAP CMOVE
    R> ;
: WORD PARSE HERE PACK$ ;
: TOKEN BL PARSE 31 MIN NP @ OVER - 1- PACK$ ;
: LINK> 3 CELLS - ;
: CODE> 2 CELLS - ;
: TYPE> 1 CELLS - ;
: DATA> CELL+ ;
: SAME?
    FOR AFT
        OVER R@ CELLS + @
        OVER R@ CELLS + @
        - ?DUP
        IF R> DROP EXIT THEN
    THEN
    NEXT 0 ;
: find
    @ BEGIN DUP WHILE
        2DUP C@ SWAP C@ = IF
        2DUP 1+ SWAP COUNT ALIGNED CELL / >R SWAP R>
        SAME? 0= IF
            2DROP SWAP DROP DUP CODE> @ SWAP -1 EXIT
        THEN 2DROP THEN
    LINK> @ REPEAT ;
: ' TOKEN CONTEXT @ find IF DROP ELSE SWAP DROP 0 THEN ;
: ! ! ;
' TX! 'EMIT !
' ?RX '?KEY !
: ['] COMPILE ' ; IMMEDIATE
: POSTPONE ' , ; IMMEDIATE
: [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE
: ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
: :NONAME HERE POSTPONE ] ;
: OVERT LAST @ CURRENT @ ! ;
: $,n
    DUP LAST ! CELL-
    DUP =WORDLIST
    SWAP !
    CELL- DUP HERE
    SWAP !
    CELL- DUP CURRENT @ @
    SWAP !
    CELL- NP ! ;
: : TOKEN $,n POSTPONE ] ;
: ; COMPILE EXIT POSTPONE [ OVERT ; IMMEDIATE
: RECURSE LAST @ CURRENT @ ! ; IMMEDIATE
: doVAR R> ;
: CREATE TOKEN $,n COMPILE doVAR OVERT ;
: DOES LAST @ CODE> @ R> SWAP ! ;
: DOES> COMPILE DOES COMPILE R> ; IMMEDIATE
: CONSTANT CREATE , DOES> @ ;
: VARIABLE CREATE 0 , ;
: 2LITERAL SWAP POSTPONE LITERAL
    POSTPONE LITERAL ; IMMEDIATE
: 2CONSTANT CREATE , , DOES> 2@ ;
: 2VARIABLE CREATE 2 CELLS ALLOT ;
: SPACE BL EMIT ;
: SPACES 0 MAX FOR SPACE NEXT ;
: PAD HERE 80 + ;
: DECIMAL 10 BASE ! ;
: HEX 16 BASE ! ;
: BINARY 2 BASE ! ;
: OCTAL 8 BASE ! ;
DECIMAL
: CHAR- 1- ;
: CHAR+ 1+ ;
: CHARS ;
: >CHAR 127 AND DUP 127 BL WITHIN IF DROP 95 THEN ;
: DIGIT 9 OVER < 7 AND + [CHAR] 0 + ;
: <# PAD HLD ! ;
: HOLD HLD @ CHAR- DUP HLD ! C! ;
: # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
: #S BEGIN # 2DUP OR 0= UNTIL ;
: SIGN 0< IF [CHAR] - HOLD THEN ;
: #> 2DROP HLD @ PAD OVER - ;
: S.R OVER - SPACES TYPE ;
: D.R >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
: U.R 0 SWAP D.R ;
: .R >R S>D R> D.R ;
: D. 0 D.R SPACE ;
: U. 0 D. ;
: . BASE @ 10 XOR IF U. EXIT THEN S>D D. ;
: ? @ . ;
: DU.R >R <# #S #> R> S.R ;
: DU. DU.R SPACE ;
: do$ R> R@ R> COUNT + ALIGNED >R SWAP >R ;
: ."| do$ COUNT TYPE ;
: $," [CHAR] " WORD COUNT + ALIGNED CP ! ;
: ." COMPILE ."| $," ; IMMEDIATE
: .( [CHAR] ) PARSE TYPE ; IMMEDIATE
: $"| do$ ;
: $" COMPILE $"| $," ; IMMEDIATE
: s" [CHAR] " PARSE HERE PACK$ ;
: CR 10 EMIT ;
: TAP OVER C! 1+ ;
: KTAP
    10 XOR
    IF
        BL TAP EXIT
    THEN
    NIP DUP ;
: ACCEPT
    OVER + OVER
    BEGIN
        2DUP XOR
    WHILE
        KEY
        DUP BL - 95 U<
        IF TAP ELSE KTAP THEN
    REPEAT DROP OVER - ;
: EXPECT ACCEPT SPAN ! DROP ;
: QUERY TIB 80 ACCEPT #TIB C! DROP 0 >IN ! ;
: DIGIT?
    >R [CHAR] 0 -
    9 OVER <
    IF 7 - DUP 10 < OR THEN
    DUP R> U< ;
: /STRING DUP >R - SWAP R> + SWAP ;
: >NUMBER
    BEGIN DUP
    WHILE >R DUP >R C@ BASE @ DIGIT?
    WHILE SWAP BASE @ UM* DROP ROT
    BASE @ UM* D+ R> CHAR+ R> 1 -
    REPEAT DROP R> R> THEN ;
: NUMBER?
    OVER C@ [CHAR] - = DUP >R IF 1 /STRING THEN
    >R >R 0 DUP R> R> -1 DPL !
    BEGIN >NUMBER DUP
    WHILE OVER C@ [CHAR] . XOR
        IF ROT DROP ROT R> 2DROP FALSE EXIT
    THEN 1 - DPL ! CHAR+ DPL @
    REPEAT 2DROP R> IF DNEGATE THEN TRUE ;
' NUMBER? 'NUMBER !
: $INTERPRET
    CONTEXT @ find
    IF DROP EXECUTE EXIT THEN
    COUNT 'NUMBER @EXECUTE IF
        DPL @ 0< IF DROP THEN EXIT THEN ." ?" TYPE ;
: $COMPILE
    CONTEXT @ find
    IF CELL- @ =IMMED =
        IF EXECUTE ELSE , THEN EXIT
    THEN COUNT 'NUMBER @EXECUTE
    IF
        DPL @ 0<
        IF DROP POSTPONE LITERAL
        ELSE POSTPONE 2LITERAL
        THEN EXIT
    THEN ." ?" TYPE ;
: eval STATE? IF $COMPILE ELSE $INTERPRET THEN ;
' eval 'EVAL !
: EVAL
    BEGIN TOKEN DUP C@ WHILE
        'EVAL @EXECUTE
    REPEAT DROP ;
: OK CR ." OK." SPACE ;
' OK 'PROMPT !
: QUIT
    BEGIN 'PROMPT @EXECUTE QUERY
    EVAL AGAIN ;
: BYE ." Good Bye " CR HALT ;
' QUIT BOOT !
: SP@ SPP @ ;
: DEPTH SP@ SP0 @ - CELL / ;
: PICK CELLS SP@ SWAP - 2 CELLS - @ ;
: .S CR DEPTH FOR AFT R@ PICK . THEN NEXT SPACE ." <SP " CR ;
: WORDS
    CONTEXT @ @ BEGIN DUP WHILE DUP COUNT TYPE LINK>
    @ SPACE REPEAT DROP CR ;

VARIABLE FILE
: OPEN F_OPEN FILE ! ;
: CLOSE FILE @ F_CLOSE ;
: FPUT FILE @ PUTC ;
: FGET FILE @ GETC ;
: FPUTS COUNT FOR AFT DUP C@ FPUT 1+ THEN NEXT DROP ;
: FTELL FILE @ F_TELL ;
: FSEEK FILE @ F_SEEK ;

: SAVEVM $" eforth.img" $" wb" OPEN 0
    16384 FOR AFT DUP C@ FPUT 1+ THEN NEXT CLOSE DROP ;

SAVEVM


Clarify usage

Clarify usage

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: <= ( a b -- f , true if A <= b ) > 0= ;
: >= ( a b -- f , true if A >= b ) < 0= ;
: NOT ( n -- !n , logical negation ) 0= ;
: DNEGATE ( d -- -d , negate by doing 0-d )
        0 swap -
;
: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: BETWEEN ( n lo hi -- flag , true if between lo & hi )
        >r over r> > >r
        < r> or 0=
;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    16 + @ \ offset in execution token for alloc size
    cells swap >body swap
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body \ get address of code for new word
        cell + \ offset to second cell in create word
        !      \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
		>r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
		r>
        :noname       ( addrz xt )
        swap !              \ save execution token in literal
; immediate

0 1- constant -1
0 2- constant -2

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

: 2* ( n -- n*2 )
        2 *
;
: 2/ ( n -- n/2 )
        2 /
;

\ define some useful constants ------------------------------
1 0= constant FALSE
0 0= constant TRUE
32 constant BL

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
	dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: SPACE  bl emit ;
: SPACES  512 min 0 max 0 ?DO space LOOP ;
: 0SP depth 0 ?do drop loop ;

\ : >NEWLINE ( -- , CR if needed )
\         out @ 0>
\         IF cr
\         THEN
\ ;

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: DABS ( d -- |d| )
        dup 0<
        IF dnegate
        THEN
;

: S>D  ( s -- d , extend signed single precision to double )
        dup 0<
        IF -1
        ELSE 0
        THEN
;

: D>S ( d -- s ) drop ;

: PARSE-WORD ( "<spaces>name<space>" -- c-addr u ) bl parse ;
: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: $TYPE  ( $string -- ) count type ;
: 'word  ( -- addr )  here ;

: EVEN    ( addr -- addr' )   dup 1 and +  ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate

: .'   ( <string> -- , type string delimited by single quote )
        state @
        IF    compile (.")  [char] ' parse ",
        ELSE [char] ' parse type
        THEN
; immediate

: C"    ( <string> -- addr , return string address, ANSI )
        state @
        IF compile (c")   ,"
        ELSE [char] " parse pad place pad
        THEN
; immediate

: S"    ( <string> -- , -- addr , return string address, ANSI )
        state @
        IF compile (s")   ,"
        ELSE [char] " parse pad place pad count
        THEN
; immediate

: "    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate
: P"    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate

\ : ""  ( <string> -- addr )
\        state @
\        IF
\                compile (C")
\                bl parse-word  ",
\        ELSE
\                bl parse-word pad place pad
\        THEN
\ ; immediate

: SLITERAL ( addr cnt -- , compile string )
	compile (S")
	",
; IMMEDIATE

: $APPEND ( addr count $1 -- , append text to $1 )
    over >r
        dup >r
    count +  ( -- a2 c2 end1 )
    swap cmove
    r> dup c@  ( a1 c1 )
    r> + ( -- a1 totalcount )
    swap c!
;

\ ANSI word to replace [COMPILE] and COMPILE ----------------
\ : POSTPONE  ( <name> -- )
\	bl word find
\	dup 0=
\	IF
\		." Postpone could not find " count type cr abort
\	ELSE
\		0>
\		IF compile,  \ immediate
\		ELSE (compile)  \ normal
\		THEN
\	THEN
\ ; immediate

\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT  ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\	." Begin AUTO.INIT ------" cr
;
: AUTO.TERM  ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\	." End AUTO.TERM ------" cr
;

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

\ ------------------------ INPUT -------------------------------

: SIGN ( n -- ) < 0 IF 45 hold THEN
;

: DIGIT ( n -- ascii )
   dup 10 < IF 48 ELSE 87 THEN + ;

: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: <= ( a b -- f , true if A <= b ) > 0= ;
: >= ( a b -- f , true if A >= b ) < 0= ;
: NOT ( n -- !n , logical negation ) 0= ;
: DNEGATE ( d -- -d , negate by doing 0-d )
        0 swap -
;
: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: BETWEEN ( n lo hi -- flag , true if between lo & hi )
        >r over r> > >r
        < r> or 0=
;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    16 + @ \ offset in execution token for alloc size
    cells swap >body swap
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body \ get address of code for new word
        cell + \ offset to second cell in create word
        !      \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
		>r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
		r>
        :noname       ( addrz xt )
        swap !              \ save execution token in literal
; immediate

0 1- constant -1
0 2- constant -2

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

: 2* ( n -- n*2 )
        2 *
;
: 2/ ( n -- n/2 )
        2 /
;

\ define some useful constants ------------------------------
1 0= constant FALSE
0 0= constant TRUE
32 constant BL

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
	dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: SPACE  bl emit ;
: SPACES  512 min 0 max 0 ?DO space LOOP ;
: 0SP depth 0 ?do drop loop ;

\ : >NEWLINE ( -- , CR if needed )
\         out @ 0>
\         IF cr
\         THEN
\ ;

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: DABS ( d -- |d| )
        dup 0<
        IF dnegate
        THEN
;

: S>D  ( s -- d , extend signed single precision to double )
        dup 0<
        IF -1
        ELSE 0
        THEN
;

: D>S ( d -- s ) drop ;

: PARSE-WORD ( "<spaces>name<space>" -- c-addr u ) bl parse ;
: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: $TYPE  ( $string -- ) count type ;
: 'word  ( -- addr )  here ;

: EVEN    ( addr -- addr' )   dup 1 and +  ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) 34 parse ", ;

: .(  ( <string> --, type string delimited by parens )
    41 parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE 34 parse type
    THEN
; immediate

: .'   ( <string> -- , type string delimited by single quote )
        state @
        IF    compile (.")  [char] ' parse ",
        ELSE [char] ' parse type
        THEN
; immediate

: C"    ( <string> -- addr , return string address, ANSI )
        state @
        IF compile (c")   ,"
        ELSE [char] " parse pad place pad
        THEN
; immediate

: S"    ( <string> -- , -- addr , return string address, ANSI )
        state @
        IF compile (s")   ,"
        ELSE [char] " parse pad place pad count
        THEN
; immediate

: "    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate
: P"    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate

\ : ""  ( <string> -- addr )
\        state @
\        IF
\                compile (C")
\                bl parse-word  ",
\        ELSE
\                bl parse-word pad place pad
\        THEN
\ ; immediate

: SLITERAL ( addr cnt -- , compile string )
	compile (S")
	",
; IMMEDIATE

: $APPEND ( addr count $1 -- , append text to $1 )
    over >r
        dup >r
    count +  ( -- a2 c2 end1 )
    swap cmove
    r> dup c@  ( a1 c1 )
    r> + ( -- a1 totalcount )
    swap c!
;

\ ANSI word to replace [COMPILE] and COMPILE ----------------
\ : POSTPONE  ( <name> -- )
\	bl word find
\	dup 0=
\	IF
\		." Postpone could not find " count type cr abort
\	ELSE
\		0>
\		IF compile,  \ immediate
\		ELSE (compile)  \ normal
\		THEN
\	THEN
\ ; immediate

\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT  ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\	." Begin AUTO.INIT ------" cr
;
: AUTO.TERM  ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\	." End AUTO.TERM ------" cr
;

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

\ ------------------------ INPUT -------------------------------

: SIGN ( n -- ) < 0 IF 45 hold THEN
;

: DIGIT ( n -- ascii )
   dup 10 < IF 48 ELSE 87 THEN + ;

: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;


?NOT-TWO-ADJACENT-1-BITS added

?NOT-TWO-ADJACENT-1-BITS added

\ KataDiversion in Forth

\ -- utils

\ empty the stack
: EMPTY
    DEPTH 0 <> IF BEGIN
                    DROP DEPTH 0 =
                  UNTIL
               THEN ;

\ power
: ** ( n1 n2 -- n1_pow_n2 ) 1 SWAP ?DUP IF 0 DO OVER * LOOP THEN NIP ;

\ compute the highest power of 2 below N.
\ e.g. : 31 -> 16, 4 -> 4
: MAXPOW2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Maxpow2 need a positive value."
                               ELSE DUP 1 = IF 1
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP I - 2 *
                                                    ( n n 2*[n-i])
                                                    R> 2 * >R ( … |R: i*2)
                                                    > ( n n>2*[n-i] )
                                                UNTIL
                                                R> 2 /
                                            THEN
                               THEN NIP ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 11 -> 1011 -> -1
\         9 -> 1001 ->  0
: ?TWO-ADJACENT-1-BITS ( n -- bool )
    \ the word uses the following algorithm :
    \ (stack|return stack)
    \ ( A N | X )  A: 0, X: N LOG2
    \ loop: if N-X > 0 then A++ else A=0 ; X /= 2
    \       return -1 if A=2
    \       if X=1 end loop and return 0
    0 SWAP DUP DUP 0 <> IF
                            MAXPOW2 >R
                            BEGIN
                                DUP I - 0 >= IF
                                                SWAP DUP 1 = IF 1+ SWAP
                                                             ELSE 1+ SWAP I -
                                                            THEN
                                             ELSE NIP 0 SWAP
                                             THEN
                                OVER
                                2 =
                                I 1 = OR
                                R> 2 / >R
                            UNTIL
                            R> 2DROP
                            2 =
                       THEN ;

: ?NOT-TWO-ADJACENT-1-BITS ( n -- bool ) ?TWO-ADJACENT-1-BITS INVERT ;

\ return the maximum number which can be made with N (given number) bits
: ?MAX-NB ( n -- m ) DUP 1 < IF DROP 0 ( 0 )
                              ELSE
                                  DUP IF DUP 2 SWAP ** NIP ( 2**n )
                                  THEN
                              THEN ;

\ return the number of numbers which can be made with N (given number) bits
\ or less, and which have not two adjacent 1 bits.
\ see http://www.codekata.com/2007/01/code_kata_fifte.html
: ?HOW-MANY-NB-NOT-TWO-ADJACENT-1-BITS ( n -- m ) ( TODO ) ;

\ KataDiversion in Forth

\ -- utils

\ empty the stack
: EMPTY
    DEPTH 0 <> IF BEGIN
                    DROP DEPTH 0 =
                  UNTIL
               THEN ;

\ power
: ** ( n1 n2 -- n1_pow_n2 ) 1 SWAP ?DUP IF 0 DO OVER * LOOP THEN NIP ;

\ compute the highest power of 2 below N.
\ e.g. : 31 -> 16, 4 -> 4
: MAXPOW2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Maxpow2 need a positive value."
                               ELSE DUP 1 = IF 1
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP I - 2 *
                                                    ( n n 2*[n-i])
                                                    R> 2 * >R ( … |R: i*2)
                                                    > ( n n>2*[n-i] )
                                                UNTIL
                                                R> 2 /
                                            THEN
                               THEN NIP ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 11 -> 1011 -> -1
\         9 -> 1001 ->  0
: ?TWO-ADJACENT-1-BITS ( n -- bool )
    \ the word uses the following algorithm :
    \ (stack|return stack)
    \ ( A N | X )  A: 0, X: N LOG2
    \ loop: if N-X > 0 then A++ else A=0 ; X /= 2
    \       return -1 if A=2
    \       if X=1 end loop and return 0
    0 SWAP DUP DUP 0 <> IF
                            MAXPOW2 >R
                            BEGIN
                                DUP I - 0 >= IF
                                                SWAP DUP 1 = IF 1+ SWAP
                                                             ELSE 1+ SWAP I -
                                                            THEN
                                             ELSE NIP 0 SWAP
                                             THEN
                                OVER
                                2 =
                                I 1 = OR
                                R> 2 / >R
                            UNTIL
                            R> 2DROP
                            2 =
                       THEN ;

\ return the maximum number which can be made with N (given number) bits
: ?MAX-NB ( n -- m ) DUP 1 < IF DROP 0 ( 0 )
                              ELSE
                                  DUP IF DUP 2 SWAP ** NIP ( 2**n )
                                  THEN
                              THEN ;

\ return the number of numbers which can be made with N (given number) bits
\ or less, and which have not two adjacent 1 bits.
\ see http://www.codekata.com/2007/01/code_kata_fifte.html
: ?HOW-MANY-NB-NOT-TWO-ADJACENT-1-BITS ( n -- m ) ( TODO ) ;


State bug.

State bug.

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if advancehms then
   	dup inter.rtcdsem @offex! ?dup if advancedhms then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

\ These two contain loops to ensure that we don't
\ drop any timer ticks on the floor.
: ADVANCEHMS ( n -- ) 0 do hms advancetime loop ;
: ADVANCEDHMS ( n -- ) 0 do dhms advancetime loop ;

: LOAD-DEFAULTS ( -- )
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	int odn.s
	int odn.m
	int odn.h
end-struct

struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

\ ----------------------------------------------------------
\ Defaults get saved in the user data page.
\ ----------------------------------------------------------
: NVRAMVALID? ( addr -- t/f )
\ *G See if there is valid data in the NVRAM.
\ ** It consists of 3 words.  If any of them are
\ ** set to 0xffff:ffff, we go with the defaults.
  _USERDATA
  dup      @ -1 <>
  over 4 + @ -1 <> and
  swap 8 + @ -1 <> and
;

: _NVRAMLOAD ( -- )
\ *G Pull the needle maximums from flash.
  $C 0 do I ud@ needle_max I + !   4 +loop
;

: NVRAM! ( -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 needle_max
 $C 0 do dup I + @  I ud!  4 +loop
 drop
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

idata \ Has to match an odn.
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

((
: interp-next drop 1 ;
: interp-reset drop ." Reset" ;

))

: RANGECHECK ( max n -- n or zero ) 2dup <= if 2drop 0 else swap drop then ;

: INTER-BUMP (  max old interp -- new )
\ *G Get the next value from the interpolator, and
\ ** reset the interpolator if it wraps around to zero.
  >R R@ interp-next  \ Get the max
  + rangecheck
  dup 0= if R> interp-reset else R> drop then
  ;

: NFETCH ( odn off -- max old )
\ *G Combine the current value with the maximum.
  >R R@ \ stash the offset.
  +  @ \ Calculate the offset address, get the current val.
  needle_max R> + @
  swap
;

: ++NEEDLE_S \ Called every time.
    odn_hms 0 odn.s nfetch ( max old )
	interp_hms interp.a inter-bump ( new )
	odn_hms odn.s !
	;

: ++NEEDLE_M ( -- )
\ *G Every time we roll the seconds, bump the minutes and the hour
	odn_hms 0 odn.m nfetch ( max old )
	interp_hms interp.b inter-bump
	odn_hms odn.m !

	odn_hms 0 odn.h nfetch ( max old )
	interp_hms interp.c inter-bump
	odn_hms odn.h !
	;

: ++NEEDLE_DS ; \ Called every time.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup odn.s w@ pwm0!
  dup odn.m w@ pwm1!
      odn.h w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  dup hms.w_m @ execute
  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a needle_max     @ raw_sec call3--
  2dup interp.b needle_max 4 + @     #60 call3--
       interp.c needle_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a needle_max     @  raw_dsec call3--
  2dup interp.b needle_max 4 + @      #100 call3--
       interp.c needle_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 xor ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec
3 4 * equ _s_seth
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin
6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ 16 > if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_seth uistate ! true exit then
  uicount @ 48 > if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_init uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,
' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( -- )
  load-defaults
  icroot 0 over inter.rtcsem ! \ Reset the free-running counters.
         0 over inter.rtcdsem ! \ Reset the free-running counters.

  begin
   	dup inter.rtcsem  @offex! ?dup if advancehms then
   	dup inter.rtcdsem @offex! ?dup if advancedhms then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

\ These two contain loops to ensure that we don't
\ drop any timer ticks on the floor.
: ADVANCEHMS ( n -- ) 0 do hms advancetime loop ;
: ADVANCEDHMS ( n -- ) 0 do dhms advancetime loop ;

: LOAD-DEFAULTS ( -- )
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	int odn.s
	int odn.m
	int odn.h
end-struct

struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

\ ----------------------------------------------------------
\ Defaults get saved in the user data page.
\ ----------------------------------------------------------
: NVRAMVALID? ( addr -- t/f )
\ *G See if there is valid data in the NVRAM.
\ ** It consists of 3 words.  If any of them are
\ ** set to 0xffff:ffff, we go with the defaults.
  _USERDATA
  dup      @ -1 <>
  over 4 + @ -1 <> and
  swap 8 + @ -1 <> and
;

: _NVRAMLOAD ( -- )
\ *G Pull the needle maximums from flash.
  $C 0 do I ud@ needle_max I + !   4 +loop
;

: NVRAM! ( -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 needle_max
 $C 0 do dup I + @  I ud!  4 +loop
 drop
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create ODN_HMS  odn allot \ On-Deck, HMS
create ODN_DHMS odn allot \ On-Deck, DHMS
create ODN_UI   odn allot \ On-Deck, Generated by the UI.
cdata

idata \ Has to match an odn.
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

((
: interp-next drop 1 ;
: interp-reset drop ." Reset" ;

))

: RANGECHECK ( max n -- n or zero ) 2dup <= if 2drop 0 else swap drop then ;

: INTER-BUMP (  max old interp -- new )
\ *G Get the next value from the interpolator, and
\ ** reset the interpolator if it wraps around to zero.
  >R R@ interp-next  \ Get the max
  + rangecheck
  dup 0= if R> interp-reset else R> drop then
  ;

: NFETCH ( odn off -- max old )
\ *G Combine the current value with the maximum.
  >R R@ \ stash the offset.
  +  @ \ Calculate the offset address, get the current val.
  needle_max R> + @
  swap
;

: ++NEEDLE_S \ Called every time.
    odn_hms 0 odn.s nfetch ( max old )
	interp_hms interp.a inter-bump ( new )
	odn_hms odn.s !
	;

: ++NEEDLE_M ( -- )
\ *G Every time we roll the seconds, bump the minutes and the hour
	odn_hms 0 odn.m nfetch ( max old )
	interp_hms interp.b inter-bump
	odn_hms odn.m !

	odn_hms 0 odn.h nfetch ( max old )
	interp_hms interp.c inter-bump
	odn_hms odn.h !
	;

: ++NEEDLE_DS ; \ Called every time.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup odn.s w@ pwm0!
  dup odn.m w@ pwm1!
      odn.h w@ pwm2!
  ;

: USE-CLOCKVALS odn_hms _use ;
: USE-UIVALS    odn_ui  _use ;

\ ----------------------------------------------------------
\ PWM/Timer Manipulation
\ ----------------------------------------------------------
_timer0 $34 + equ _PWM0
_timer0 $44 + equ _PWM1
_timer0 $54 + equ _PWM2

: PWM0! ( n -- ) _pwm0 ! ;
: PWM1! ( n -- ) _pwm1 ! ;
: PWM2! ( n -- ) _pwm2 ! ;

: PWM0@ ( -- n ) _pwm0 w@ ;
: PWM1@ ( -- n ) _pwm1 w@ ;
: PWM2@ ( -- n ) _pwm2 w@ ;

: SCALE0 #1000 0 do I pwm0! loop ;
: SCALE1 #1000 0 do I pwm0! [asm wfi asm] loop ;

\ ----------------------------------------------------------
\ PWM/Timer Quadrature
\ ----------------------------------------------------------

: QUAD@ ( addr -- n ) \ Fetch and zero
  @off [asm sxth tos, tos asm] ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_ds , ' ++needle_dm , \ Words to invoke
cdata

\ Core concept - We update the seconds
\ each time this gets called.
\ If the seconds wrap, we update the minutes
\ and the hours.
: ADVANCETIME ( struct-addr -- )
  dup hms.w_s @ execute \ Invoke the official update word.
  1 over hms.subsec +!  \ Increment
   dup hms.subsec @
   over hms.maxsubsec @ < if drop exit then \ If less then max, we're done
  0 over hms.subsec ! \ Reset the subsecs

  1 over hms.s +!
   dup hms.s @ over hms.maxsec @ < if drop exit then
  0 over hms.s ! \ Reset the seconds

  dup hms.w_m @ execute
  1 over hms.m +!
   dup hms.m @ over hms.maxsec @ < if drop exit then
  0 over hms.m ! \ Reset the minutes

  1 over hms.h +!
   dup hms.h @ over hms.maxhour @ < if drop exit then
  0 over hms.h ! \ Reset the minutes

  drop

;

: ? @ . ;
: .hms ( addr -- )
  dup hms.h ?
  dup hms.m ?
  dup hms.s ?
  hms.subsec ?
  cr
;

\ : foo 0 do hms advancetime loop ;

\ ----------------------------------------------------------
\ The interpolator.
\ Implement bresenhams algorithm.  All of this code already
\ exists in C, but we'll own the data structures.  They contain
\ A total of 4 words - fixed, err, num, & denom
\ ----------------------------------------------------------
udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

#16  #60 * equ raw_sec
#10 #100 * equ raw_dsec

: INTERP-INIT ( -- )
  (interp_init) interp_hms
  2dup interp.a needle_max     @ raw_sec call3--
  2dup interp.b needle_max 4 + @     #60 call3--
       interp.c needle_max 8 + @     #12 call3--

  (interp_init) interp_dhms
  2dup interp.a needle_max     @  raw_dsec call3--
  2dup interp.b needle_max 4 + @      #100 call3--
       interp.c needle_max 8 + @       #10 call3--
;

\ Call the reset fn.
: INTERP-RESET ( interp_addr -- )
  (interp_reset) swap call1--
;

: INTERP-NEXT ( addr -- n )
  (interp_next) swap call1--n
;

\ ============================ UNTESTED =======================
\ VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV

\ ----------------------------------------------------------
\ User Interface
\ ----------------------------------------------------------
variable uistate
variable uicount

_GPIO $64  + equ _BUTTONIO
: BUTTONUP?   ( -- t/f ) _buttonio @ 1 and ;
: BUTTONDOWN? ( -- t/f )  buttonup? 1 xor ;

\ The wrapper for all of the UI stuff.
\ Returns true if the UI is active - ie, use the values generated by the UI.
: UIUPDATE ( -- t/f )
  StateHandlers uistate @ + @ execute
;

\ -----------------------------------------------
\ State numbers.  These are defined x4 so that
\ we can just use the state number as an index
\ into a table of words.
\ -----------------------------------------------
0 4 * equ _s_init
1 4 * equ _s_b1
2 4 * equ _s_1sec
3 4 * equ _s_seth
4 4 * equ _s_pendset_m
5 4 * equ _s_setmin
6 4 * equ _s_pendcal0
7 4 * equ _s_cal0
8 4 * equ _s_pendcalh
9 4 * equ _s_calh
10 4 * equ _s_pendcalm
11 4 * equ _s_calm
12 4 * equ _s_pendcals
13 4 * equ _s_cals

\ All of the state handlers.
\ Everybody needs to know the state of the button, so that must
\ get passed in, thus they all look like this:
\ state ( t/f -- t/f )
: shInit false
   buttondown? if
   _s_b1 uistate !
   uicount off \ Reset this.
   then
  ;

\ Waiting for a full second to go by.
: shB1 false
  buttonup? if _s_init uistate ! exit then
  \ The Button is down.
  uicount @ 16 > if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_seth uistate ! true exit then
  uicount @ 48 > if
    _s_pendcal0 uistate !
    else
    1 uicount +!
	then
;

\ -------------------------------------------------
\ Setting the time
\ -------------------------------------------------
: shSetH true buttondown? if _s_pendset_m uistate ! exit then ;

: shPendSetM true  buttonup? if _s_setmin uistate ! then ;
: shSetMin true  buttondown? if _s_pendset_m uistate ! exit then ;

\ -------------------------------------------------
\ Calibration
\ -------------------------------------------------
: shPendCal0 true  buttonup? if _s_cal0 uistate ! then ;
: shCal0 true    buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then ;

: shPendCalS true buttonup? if _s_calm uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,
' shSetH ,
' shPendSetM ,  ' shSetMin ,

' shPendCal0 ,  ' shCal0 ,
' shPendCalH ,  ' shCalH ,
' shPendCalM ,  ' shCalM ,
' shPendCalS ,  ' shCalS ,


Added numeric output primitives, <# and friends

( block 1  -- Main load block )

VARIABLE BLK
: FH  BLK @ + ;  \ relative block
: LOAD  BLK @ SWAP DUP BLK ! (LOAD) BLK ! ;

30 LOAD
( shadow 1 )
( block 2 )
( shadow 2 )
( block 3 )
( shadow 3 )

( block 10 )
( shadow 10 )
( block 11 )
( shadow 11 )
( block 12 )
( shadow 12 )

( block 30  CORE words )

1 FH 7 FH THRU

( shadow 30 )
( block 31 stack primitives )

: ROT   >R SWAP R> SWAP ;
: ?DUP  DUP IF DUP THEN ;

( Not part of CORE, disabled at the moment )
\ : -ROT  SWAP >R SWAP R> ;  \ or ROT ROT
\ : NIP  ( n1 n2 -- n2 )       SWAP DROP ;
\ : TUCK ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;

: 2DROP   DROP DROP ;
: 2DUP  OVER OVER ;
: 2SWAP  ROT >R ROT R> ;
: 2OVER  >R >R 2DUP R> R> 2SWAP ;
( shadow 31 )
( block 32  comparisons )

-1 CONSTANT TRUE   0 CONSTANT FALSE

:  =  ( n n -- f) XOR  0= ;
:  < ( n n -- f ) - 0< ;
:  > ( n n -- f ) SWAP < ;

: MAX ( n n -- n ) 2DUP < IF SWAP THEN DROP ;
: MIN ( n n -- n ) 2DUP > IF SWAP THEN DROP ;

: WITHIN  ( u ul uh -- f ) OVER - >R - R> U< ;
( shadow 32 )
( block 33 ALU )

: 1+  1 + ;
: 1-  1 - ;
: INVERT  TRUE XOR ;
: NEGATE  INVERT 1+ ;
: DNEGATE  INVERT SWAP NEGATE SWAP OVER 0= - ;
: S>D  ( n -- d ) DUP 0< ;   \ sign extend
: ABS  S>D IF NEGATE THEN ;
: DABS  DUP 0< IF DNEGATE THEN ;

: +-  0< IF NEGATE THEN ;
: D+- 0< IF DNEGATE THEN ;

( shadow 33 )
( block 34  variables )

VARIABLE BASE
: DECIMAL 10 BASE ! ;   : HEX 16 BASE ! ;

VARIABLE DP
( shadow 34 )
( block 35 math )

: SM/REM ( d n -- r q )  \ symmetric
  OVER >R >R DABS R@ ABS UM/MOD
  R> R@ XOR 0< IF NEGATE THEN
  R> 0< IF >R NEGATE R> THEN ;

: FM/MOD ( d n -- r q )  \ floored
  DUP 0< DUP >R IF NEGATE >R DNEGATE R> THEN
  >R DUP 0< IF R@ + THEN
  R> UM/MOD R> IF >R NEGATE R> THEN ;

: /MOD OVER 0< SWAP FM/MOD ;
: MOD  /MOD DROP ;
: /    /MOD SWAP DROP ;

( shadow 35 )
( block 36  math continued )

: *  UM* DROP ;
: M*  2DUP XOR R> ABS SWAP ABS UM* R> D+- ;
: */MOD  >R M* R> FM/MOD ;
: */     */MOD SWAP DROP ;

: 2* DUP + ;
\ 2/ which is right shift is native

: LSHIFT ( x1 u -- x2 )
  BEGIN DUP WHILE SWAP 2* SWAP 1- REPEAT DROP ;

: RSHIFT ( x1 u -- x2 )
  BEGIN DUP WHILE SWAP 2/ SWAP 1- REPEAT DROP ;
  ( shadow 36 )
( block 37 numeric output primitives )

VARIABLE HLD
: HERE ( -- addr )  DP @ ;
: PAD ( -- c-addr )  HERE 64 CHARS + ;

: <# ( -- )  PAD HLD ! ;
: #> ( xd -- c-addr u )  2DROP HLD @ PAD OVER - ;
: HOLD ( c -- )  HLD @ -1 CHARS - DUP HLD ! C! ;
: DIGIT ( u -- c )  9 OVER < 7 AND + 30 +  ;
: # ( ud1 -- ud2 )
  0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
: #S ( ud1 -- ud2 )  BEGIN # 2DUP OR 0= UNTIL ;
: SIGN ( n -- )  0< IF 45 ( - ) HOLD THEN ;

( shadow 37 )
( block 38 )
( shadow 38 )
( block 39 )
( shadow 39 )
( block 40 compiler )

: VARIABLE CREATE 1 CELLS ALLOT ;

VARIABLE STATE  ( compilation state variable )
0 STATE !       ( interpreting by default )
: [  FALSE STATE ! ;
: ]  TRUE STATE ! ;

( Colon definitions )
: :  CREATE ] ;
: ;  POSTPONE EXIT SMUDGE [ ; IMMEDIATE

( shadow 40 )
( block 41 )
( shadow 41 )
( block 42 interpreter )

CREATE _INPUT-BUFFER 80 CHARS ALLOT ( may do this internally? )

: EVALUATE  >IN @ >R 0 >IN ! SOURCE >R >R #IN 2! _INTERPRET
    R> R> #IN 2! R> >IN ! ;

: QUIT  _RESET-RSTACK
      BEGIN
        BEGIN
	  _READ-LINE 0 >IN ! _INPUT-BUFFER 0 EVALUATE CR
	  STATE @
        UNTIL ." ok "  ( exhausted input in interpretation mode )
      AGAIN ;
( shadow 42 )

( block 1  -- Main load block )

VARIABLE BLK
: FH  BLK @ + ;  \ relative block
: LOAD  BLK @ SWAP DUP BLK ! (LOAD) BLK ! ;

30 LOAD
( shadow 1 )
( block 2 )
( shadow 2 )
( block 3 )
( shadow 3 )

( block 10 )
( shadow 10 )
( block 11 )
( shadow 11 )
( block 12 )
( shadow 12 )

( block 30  CORE words )

1 FH 6 FH THRU

( shadow 30 )
( block 31 stack primitives )

: ROT   >R SWAP R> SWAP ;
: ?DUP  DUP IF DUP THEN ;

( Not part of CORE, disabled at the moment )
\ : -ROT  SWAP >R SWAP R> ;  \ or ROT ROT
\ : NIP  ( n1 n2 -- n2 )       SWAP DROP ;
\ : TUCK ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;

: 2DROP   DROP DROP ;
: 2DUP  OVER OVER ;
: 2SWAP  ROT >R ROT R> ;
: 2OVER  >R >R 2DUP R> R> 2SWAP ;
( shadow 31 )
( block 32  comparisons )

-1 CONSTANT TRUE   0 CONSTANT FALSE

:  =  ( n n -- f) XOR  0= ;
:  < ( n n -- f ) - 0< ;
:  > ( n n -- f ) SWAP < ;

: MAX ( n n -- n ) 2DUP < IF SWAP THEN DROP ;
: MIN ( n n -- n ) 2DUP > IF SWAP THEN DROP ;

: WITHIN  ( u ul uh -- f ) OVER - >R - R> U< ;
( shadow 32 )
( block 33 ALU )

: 1+  1 + ;
: 1-  1 - ;
: INVERT  TRUE XOR ;
: NEGATE  INVERT 1+ ;
: DNEGATE  INVERT SWAP NEGATE SWAP OVER 0= - ;
: S>D  ( n -- d ) DUP 0< ;   \ sign extend
: ABS  S>D IF NEGATE THEN ;
: DABS  DUP 0< IF DNEGATE THEN ;

: +-  0< IF NEGATE THEN ;
: D+- 0< IF DNEGATE THEN ;

( shadow 33 )
( block 34  variables )

VARIABLE BASE
: DECIMAL 10 BASE ! ;   : HEX 16 BASE ! ;
( shadow 34 )
( block 35 math )

: SM/REM ( d n -- r q )  \ symmetric
  OVER >R >R DABS R@ ABS UM/MOD
  R> R@ XOR 0< IF NEGATE THEN
  R> 0< IF >R NEGATE R> THEN ;

: FM/MOD ( d n -- r q )  \ floored
  DUP 0< DUP >R IF NEGATE >R DNEGATE R> THEN
  >R DUP 0< IF R@ + THEN
  R> UM/MOD R> IF >R NEGATE R> THEN ;

: /MOD OVER 0< SWAP FM/MOD ;
: MOD  /MOD DROP ;
: /    /MOD SWAP DROP ;

( shadow 35 )
( block 36  math continued )

: *  UM* DROP ;
: M*  2DUP XOR R> ABS SWAP ABS UM* R> D+- ;
: */MOD  >R M* R> FM/MOD ;
: */     */MOD SWAP DROP ;

: 2* DUP + ;
\ 2/ which is right shift is native

: LSHIFT ( x1 u -- x2 )
  BEGIN DUP WHILE SWAP 2* SWAP 1- REPEAT DROP ;

: RSHIFT ( x1 u -- x2 )
  BEGIN DUP WHILE SWAP 2/ SWAP 1- REPEAT DROP ;
  ( shadow 36 )
( block 37 )
( shadow 37 )
( block 38 )
( shadow 38 )
( block 39 )
( shadow 39 )
( block 40 compiler )

: VARIABLE CREATE 1 CELLS ALLOT ;

VARIABLE STATE  ( compilation state variable )
0 STATE !       ( interpreting by default )
: [  FALSE STATE ! ;
: ]  TRUE STATE ! ;

( Colon definitions )
: :  CREATE ] ;
: ;  POSTPONE EXIT SMUDGE [ ; IMMEDIATE

( shadow 40 )
( block 41 )
( shadow 41 )
( block 42 interpreter )

CREATE _INPUT-BUFFER 80 CHARS ALLOT ( may do this internally? )

: EVALUATE  >IN @ >R 0 >IN ! SOURCE >R >R #IN 2! _INTERPRET
    R> R> #IN 2! R> >IN ! ;

: QUIT  _RESET-RSTACK
      BEGIN
        BEGIN
	  _READ-LINE 0 >IN ! _INPUT-BUFFER 0 EVALUATE CR
	  STATE @
        UNTIL ." ok "  ( exhausted input in interpretation mode )
      AGAIN ;
( shadow 42 )


Fix up the conditional compilation code.


More demos!

More demos!

(( App Startup ))

0 value JT \ The Jumptable

\ -------------------------------------------
\ The word that sets everything up.
\ This runs before the intro banner, after
\ Init-multi.
\ -------------------------------------------
: StartApp
	hex
	init-dp @ dp ! \ Set the dictionary pointer so that we can function.
	\ I have no idea why I am doing this instead of the compilation system.

	1 getruntimelinks to jt
	." StartApp!"

	4 [ SCSSCR _SCS + ] literal  ! \ Set deepsleep

;

\ ------------------------------------------
\ Application code
\ ------------------------------------------
struct tod
 1 field h
 1 field m
 1 field s
end-struct

udata
create hms tod allot
cdata

: +CAP ( n max -- n ) >R 1 + dup r> = if drop 0 then ;

: ADVANCE ( tod -- )
  dup s c@ #60 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #60 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #24 +cap  2dup swap h c! \ advance minutes

  2drop
;

\ ----------------------------------------------
\ Tools for writing to the LCD
\ ----------------------------------------------
: LCD#! ( n -- ) jt LCD_# @ swap call1-- ;
variable thecount

: wakestart 1 $10 wakereq drop ; \ Request a wake
: wakestop  1   0 wakereq drop ; \ No more, please.

: COUNT-WORD
  wakestart
  begin
    pause
    thecount dup  @ 1+ dup lcd#! swap !
    stop
  again
;

: COUNT-WORDd
  begin
    pause self msg? if get-message drop \ We don't care who sent it.
     case
       0 of wakestop endof
       1 of wakestart endof
     endcase
     then

    thecount dup @ 1+ dup lcd#! swap !
    stop
  again
;

: interp-next ( addr -- ) \ A fixed version.  Returns amount to step
  dup @ \ err
  #103 - dup 1 > if swap ! #13 exit then
  \ Otherwise, we need to adjust
  #125 + swap ! #14
;

variable err

: COUNT-DT
  begin
    0   err interp-next wakereq drop \ Don't keep the return code.
    pause
    thecount dup  @ 1+ dup lcd#! swap !
  again
;

((
task foo
' count-word foo initiate

))

(( App Startup ))

0 value JT \ The Jumptable

\ -------------------------------------------
\ The word that sets everything up.
\ This runs before the intro banner, after
\ Init-multi.
\ -------------------------------------------
: StartApp
	hex
	init-dp @ dp ! \ Set the dictionary pointer so that we can function.
	\ I have no idea why I am doing this instead of the compilation system.

	1 getruntimelinks to jt
	." StartApp!"

	4 [ SCSSCR _SCS + ] literal  ! \ Set deepsleep

;

\ ------------------------------------------
\ Application code
\ ------------------------------------------
struct tod
 1 field h
 1 field m
 1 field s
end-struct

udata
create hms tod allot
cdata

: +CAP ( n max -- n ) >R 1 + dup r> = if drop 0 then ;

: ADVANCE ( tod -- )
  dup s c@ #60 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #60 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #24 +cap  2dup swap h c! \ advance minutes

  2drop
;

\ ----------------------------------------------
\ Tools for writing to the LCD
\ ----------------------------------------------
: LCD#! ( n -- ) jt LCD_# @ swap call1-- ;
variable thecount

: wakestart 1 $10 wakereq ; \ Request a wake
: wakestop  1   0 wakereq ; \ No more, please.

: COUNT-WORD
  wakestart
  begin
    pause
    thecount dup  @ 1+ dup lcd#! swap !
    stop
  again
;

: COUNT-WORDd
  begin
    pause self msg? if get-message drop \ We don't care who sent it.
     case
       0 of wakestop endof
       1 of wakestart endof
     endcase
     then

    thecount dup @ 1+ dup lcd#! swap !
    stop
  again
;

((
task foo
' count-word foo initiate
))