More system words

More system words

: (   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 )
        1 lshift
;
: 2/ ( n -- n/2 )
        1 rshift
;

\ 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 ;

: /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 ;

: (   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 ! ;

: 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 ;

: [  ( -- , 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

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

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

: /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

: 'word  ( -- addr )  here ;

: (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

: 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 +!
;

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

: SIGN ( n -- ) < 0 IF 45 hold THEN
;
: # ( n -- n )
    base @ /mod swap digit hold ;

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

: (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

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

\ 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
;


Update test.4th

Update test.4th

( simple assembler/VM test - capitalize [-32] console input )
( requires assembler )

0 const u
1 const c

  32 u ldc,
 label &start
     c in,
 c u c sub,
     c out,
&start jump,

assemble

( simple assembler/VM test - capitalize [-32] console input )

0 const u
1 const c

  32 u ldc,
 label &start
     c in,
 c u c sub,
     c out,
&start jump,

assemble


We need a word to fetch the latest from the quadrature encoder.

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( n -- )
  icroot inter.rtcsem 0 over ! \ Reset the free-running counter.
  swap \ addr n --
  0 do
   dup @resetex! ?dup if advance else [asm wfi asm] then
  loop
  drop
;

: CLOCKINIT ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
;

\ Heres where we advance any needles.
: ADVANCE ( n -- )
  pwm0@ + pwm0!
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
udata
create NEEDLEMAX 3 cells allot
cdata

: ++NEEDLE_S ; \ Called ever time.
: ++NEEDLE_M ; \ Every time we roll the seconds.

\ ----------------------------------------------------------
\ 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.
\ ----------------------------------------------------------
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

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_s , ' ++needle_m , \ 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.
\ UNTESTED
: 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

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

  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_a 4 cells allot
create interp_b 4 cells allot
create interp_c 4 cells allot
cdata

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

: INTERP-INIT ( -- )
  (interp_init)
  dup interp_a #850 raw_sec call3--
  dup interp_b #850     #60 call3--
      interp_c #850     #12 call3--
;

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

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

(( Clock Code ))

\ The gadget that drives it all.   This is rigged for debugging,
\ terminate it by setting clockterm to non-zero.
: CLOCKSTART ( n -- )
  icroot inter.rtcsem 0 over ! \ Reset the free-running counter.
  swap \ addr n --
  0 do
   dup @resetex! ?dup if advance else [asm wfi asm] then
  loop
  drop
;

: CLOCKINIT ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
;

\ Heres where we advance any needles.
: ADVANCE ( n -- )
  pwm0@ + pwm0!
;

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
udata
create NEEDLEMAX 3 cells allot
cdata

: ++NEEDLE_S ; \ Called ever time.
: ++NEEDLE_M ; \ Every time we roll the seconds.

\ ----------------------------------------------------------
\ 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 ;

\ ----------------------------------------------------------
\ Keeping track of the time.
\ ----------------------------------------------------------
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

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_s , ' ++needle_m , \ 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.
\ UNTESTED
: 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

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

  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_a 4 cells allot
create interp_b 4 cells allot
create interp_c 4 cells allot
cdata

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

: INTERP-INIT ( -- )
  (interp_init)
  dup interp_a #850 raw_sec call3--
  dup interp_b #850     #60 call3--
      interp_c #850     #12 call3--
;

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

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


Basic, working state machine for needle calibration.   Needs to save the results.

(( 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 ;
: CLIP  ( n -- n) \ Force the contents to be legal ( 0-999 )
  dup 0 < if drop 0 exit then
  dup #999 > if drop #999 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
\ ----------------------------------------------------------

_timer1 $24 + equ QUAD-IN

\ The Quadrature encoder produces two per detent.
: QUAD@ ( -- n ) \ Fetch and zero
  quad-in @off
  [asm sxth tos, tos asm]
  [asm asr .s tos, tos, # 1 asm] \ Divide by two,
  ;

\ ----------------------------------------------------------
\ 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
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
;

: uitest
  uistate @ 4 / . ." ->" uiupdate uistate @ 4 / .
  uicount @ . if ." True" else ." False" then
;

\ -----------------------------------------------
\ 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_set_h
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

4 equ downcount_1s
16 equ downcount_3s

\ 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 @ downcount_1s >= if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_set_h uistate ! exit then
  uicount @ downcount_3s >= 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 ! helpODNClear then ;
: shCal0 true buttondown? if _s_pendcalh uistate ! exit then ;

: shPendCalH true buttonup? if _s_calh uistate ! helpODNMid then ;
: shCalH true   buttondown? if _s_pendcalm uistate ! exit then
  odn_ui odn.h helpQuad@ ;

: shPendCalM true buttonup? if _s_calm uistate ! then ;
: shCalM true   buttondown? if _s_pendcals uistate ! exit then
  odn_ui odn.m helpQuad@ ;

: shPendCalS true buttonup? if _s_cals uistate ! then ;
: shCalS true   buttondown? if _s_init uistate ! exit then
  odn_ui odn.s helpQuad@ ;

\ -------------------------------------------------
\ Helpers
\ -------------------------------------------------
: helpODNClear ( -- ) \ Set them all to zero
  odn_ui odn bounds do I off 4 +loop ;
: helpODNMid ( -- ) \ Set them all to 500
  odn_ui odn bounds do #750 I ! 4 +loop ;
: helpQuad@ ( addr -- ) \ update a location with the quadrature value
  dup @ quad@ + clip swap ! ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,

' shSetH ,
' shPendSetM ,  ' shSetMin ,

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

\ -------------------------------------------------
\ Setting the time.
\ -------------------------------------------------
variable adj_i \ THe working index into the points array.

udata
create adj_points #50 cells allot \ 100 16-bit words.
create interp_set  _interp_set allot
cdata

\ Generate a list of points.
: MAKE-SET-LIST ( max steps )
  2dup
  >R  (interp_init) swap interp_set swap R> call3--

  \ Since zero is first, do the w! first.
  swap drop   0 swap \ Keep a running counter.
  0 do
    dup I adj_points[]! \ Save the existing value
    interp_set interp-next +
  loop
  drop
  ;

: ADJ_POINTS[]! ( data index -- ) 2* adj_points + w! ;
: ADJ_POINTS[]@ ( index -- n )    2* adj_points + w@ ;

(( 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
\ ----------------------------------------------------------

_timer1 $24 + equ QUAD-IN

\ The Quadrature encoder produces two per detent.
: QUAD@ ( -- n ) \ Fetch and zero
  quad-in @off
  [asm sxth tos, tos asm]
  [asm asr .s tos, tos, # 1 asm] \ Divide by two,
  ;

\ ----------------------------------------------------------
\ 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
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_set_h
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

4 equ downcount_1s
16 equ downcount_3s

\ 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 @ downcount_1s >= if
    _s_1sec uistate !
    else
    1 uicount +!
	then
  ;

\ We're in the 1 second state
: sh1sec true
  buttonup? if _s_set_h uistate ! exit then
  uicount @ downcount_3s >= 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 ;
\ -------------------------------------------------
\ Helpers
\ -------------------------------------------------
: helpODNClear ( -- ) \ Set them all to zero
  odn_ui odn bounds do I off 4 +loop ;

create StateHandlers
' shInit ,
' shB1 ,
' sh1sec ,

' shSetH ,
' shPendSetM ,  ' shSetMin ,

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

\ -------------------------------------------------
\ Setting the time.
\ -------------------------------------------------
variable adj_i \ THe working index into the points array.

udata
create adj_points #50 cells allot \ 100 16-bit words.
create interp_set  _interp_set allot
cdata

\ Generate a list of points.
: MAKE-SET-LIST ( max steps )
  2dup
  >R  (interp_init) swap interp_set swap R> call3--

  \ Since zero is first, do the w! first.
  swap drop   0 swap \ Keep a running counter.
  0 do
    dup I adj_points[]! \ Save the existing value
    interp_set interp-next +
  loop
  drop
  ;

: ADJ_POINTS[]! ( data index -- ) 2* adj_points + w! ;
: ADJ_POINTS[]@ ( index -- n )    2* adj_points + w@ ;


added compile and conditionals

added compile and conditionals

: (   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)
\ *********************************************************************
: CELL 1 ;
: BL 32 ;

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

: CELL+  ( x -- x+cell )  cell + ;
: CELL-  ( x -- x-cell )  cell - ;

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

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;
: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1 + swap c@ ;
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

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

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ cell 1- ] literal +
    [ cell 1- invert ] literal and ;
: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;

\ 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 ;

: .( 41 parse type ; immediate

\ 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

: (   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 Foth 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)
\ *********************************************************************

: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

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

: COUNT  dup 1 + swap c@ ;
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

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

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

: CONDITIONAL_KEY 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 ;

: .( 41 parse type ; immediate

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


Use primitive U. instead

Use primitive U. instead

\ @(#) numberio.fth 98/01/26 1.2
\ numberio.fth
\
\ numeric conversion
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license.  The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.

anew task-numberio.fth
decimal

\ ------------------------ INPUT -------------------------------
\ Convert a single character to a number in the given base.
: DIGIT   ( char base -- n true | char false )
	>r
\ convert lower to upper
	dup ascii a < not
	IF
		ascii a - ascii A +
	THEN
\
	dup dup ascii A 1- >
	IF ascii A - ascii 9 + 1+
	ELSE ( char char )
		dup ascii 9 >
		IF
			( between 9 and A is bad )
			drop 0 ( trigger error below )
		THEN
	THEN
	ascii 0 -
	dup r> <
	IF dup 1+ 0>
		IF nip true
		ELSE drop FALSE
		THEN
	ELSE drop FALSE
	THEN
;

: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )
	>r
	BEGIN
		r@ 0>    \ any characters left?
		IF
			dup c@ base @
			digit ( ud1 c-addr , n true | char false )
			IF
				TRUE
			ELSE
				drop FALSE
			THEN
		ELSE
			false
		THEN
	WHILE ( -- ud1 c-addr n  )
		swap >r  ( -- ud1lo ud1hi n  )
		swap  base @ ( -- ud1lo n ud1hi base  )
		um* drop ( -- ud1lo n ud1hi*baselo  )
		rot  base @ ( -- n ud1hi*baselo ud1lo base )
		um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )
		d+  ( -- ud2 )
		r> 1+     \ increment char*
		r> 1- >r  \ decrement count
	REPEAT
	r>
;

\ obsolete
: CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )
	256 >NUMBER DROP
;

0 constant NUM_TYPE_BAD
1 constant NUM_TYPE_SINGLE
2 constant NUM_TYPE_DOUBLE

\ This is similar to the F83 NUMBER? except that it returns a number type
\ and then either a single or double precision number.
: ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )
	dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?

\ prepare for >number
	0 0 2swap ( 0 0 c-addr cnt )

\ check for '-' at beginning, skip if present
	over c@ ascii - = \ is it a '-'
	dup >r            \ save flag
	IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )
	THEN
\
	>number dup 0=   \ convert as much as we can
	IF
		2drop    \ drop addr cnt
		drop     \ drop hi part of num
		r@       \ check flag to see if '-' sign used
		IF  negate
		THEN
		NUM_TYPE_SINGLE
	ELSE  ( -- d addr cnt )
		1 = swap             \ if final character is '.' then double
		c@ ascii . =  AND
		IF
			r@      \ check flag to see if '-' sign used
			IF  dnegate
			THEN
			NUM_TYPE_DOUBLE
		ELSE
			2drop
			NUM_TYPE_BAD
		THEN
	THEN
	rdrop
;

: (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )
	count ((number?))
;

defer number?
' (number?) is number?

\ hex
\ 0sp c" xyz" (number?) .s
\ 0sp c" 234" (number?) .s
\ 0sp c" -234" (number?) .s
\ 0sp c" 234." (number?) .s
\ 0sp c" -234." (number?) .s
\ 0sp c" 1234567855554444." (number?) .s

\ ------------------------ OUTPUT ------------------------------
\ Number output based on F83
variable HLD    \ points to last character added

: hold   ( char -- , add character to text representation)
	-1 hld  +!
	hld @  c!
;
: <#     ( -- , setup conversion )
	pad hld !
;
: #>     ( d -- addr len , finish conversion )
	2drop  hld @  pad  over -
;
: sign   ( n -- , add '-' if negative )
	0<  if  ascii - hold  then
;
: #      ( d -- d , convert one digit )
   base @  mu/mod rot 9 over <
   IF  7 +
   THEN
   ascii 0 + hold
;
: #s     ( d -- d , convert remaining digits )
	BEGIN  #  2dup or 0=
	UNTIL
;

: (UD.) ( ud -- c-addr cnt )
	<# #s #>
;
: UD.   ( ud -- , print unsigned double number )
	(ud.)  type space
;
: UD.R  ( ud n -- )
	>r  (ud.)  r> over - spaces type
;
: (D.)  ( d -- c-addr cnt )
	tuck dabs <# #s rot sign #>
;
: D.    ( d -- )
	(d.)  type space
;
: D.R   ( d n -- , right justified )
	>r  (d.)  r>  over - spaces  type
;

: (U.)  ( u -- c-addr cnt )
	0 (ud.)
;
: U.R   ( u n -- , print right justified )
	>r  (u.)  r> over - spaces  type
;
: (.)   ( n -- c-addr cnt )
	dup abs 0 <# #s rot sign #>
;
: .R    ( n l -- , print right justified)
	>r  (.)  r> over - spaces type
;

\ @(#) numberio.fth 98/01/26 1.2
\ numberio.fth
\
\ numeric conversion
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license.  The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.

anew task-numberio.fth
decimal

\ ------------------------ INPUT -------------------------------
\ Convert a single character to a number in the given base.
: DIGIT   ( char base -- n true | char false )
	>r
\ convert lower to upper
	dup ascii a < not
	IF
		ascii a - ascii A +
	THEN
\
	dup dup ascii A 1- >
	IF ascii A - ascii 9 + 1+
	ELSE ( char char )
		dup ascii 9 >
		IF
			( between 9 and A is bad )
			drop 0 ( trigger error below )
		THEN
	THEN
	ascii 0 -
	dup r> <
	IF dup 1+ 0>
		IF nip true
		ELSE drop FALSE
		THEN
	ELSE drop FALSE
	THEN
;

: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )
	>r
	BEGIN
		r@ 0>    \ any characters left?
		IF
			dup c@ base @
			digit ( ud1 c-addr , n true | char false )
			IF
				TRUE
			ELSE
				drop FALSE
			THEN
		ELSE
			false
		THEN
	WHILE ( -- ud1 c-addr n  )
		swap >r  ( -- ud1lo ud1hi n  )
		swap  base @ ( -- ud1lo n ud1hi base  )
		um* drop ( -- ud1lo n ud1hi*baselo  )
		rot  base @ ( -- n ud1hi*baselo ud1lo base )
		um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )
		d+  ( -- ud2 )
		r> 1+     \ increment char*
		r> 1- >r  \ decrement count
	REPEAT
	r>
;

\ obsolete
: CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )
	256 >NUMBER DROP
;

0 constant NUM_TYPE_BAD
1 constant NUM_TYPE_SINGLE
2 constant NUM_TYPE_DOUBLE

\ This is similar to the F83 NUMBER? except that it returns a number type
\ and then either a single or double precision number.
: ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )
	dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?

\ prepare for >number
	0 0 2swap ( 0 0 c-addr cnt )

\ check for '-' at beginning, skip if present
	over c@ ascii - = \ is it a '-'
	dup >r            \ save flag
	IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )
	THEN
\
	>number dup 0=   \ convert as much as we can
	IF
		2drop    \ drop addr cnt
		drop     \ drop hi part of num
		r@       \ check flag to see if '-' sign used
		IF  negate
		THEN
		NUM_TYPE_SINGLE
	ELSE  ( -- d addr cnt )
		1 = swap             \ if final character is '.' then double
		c@ ascii . =  AND
		IF
			r@      \ check flag to see if '-' sign used
			IF  dnegate
			THEN
			NUM_TYPE_DOUBLE
		ELSE
			2drop
			NUM_TYPE_BAD
		THEN
	THEN
	rdrop
;

: (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )
	count ((number?))
;

defer number?
' (number?) is number?

\ hex
\ 0sp c" xyz" (number?) .s
\ 0sp c" 234" (number?) .s
\ 0sp c" -234" (number?) .s
\ 0sp c" 234." (number?) .s
\ 0sp c" -234." (number?) .s
\ 0sp c" 1234567855554444." (number?) .s

\ ------------------------ OUTPUT ------------------------------
\ Number output based on F83
variable HLD    \ points to last character added

: hold   ( char -- , add character to text representation)
	-1 hld  +!
	hld @  c!
;
: <#     ( -- , setup conversion )
	pad hld !
;
: #>     ( d -- addr len , finish conversion )
	2drop  hld @  pad  over -
;
: sign   ( n -- , add '-' if negative )
	0<  if  ascii - hold  then
;
: #      ( d -- d , convert one digit )
   base @  mu/mod rot 9 over <
   IF  7 +
   THEN
   ascii 0 + hold
;
: #s     ( d -- d , convert remaining digits )
	BEGIN  #  2dup or 0=
	UNTIL
;

: (UD.) ( ud -- c-addr cnt )
	<# #s #>
;
: UD.   ( ud -- , print unsigned double number )
	(ud.)  type space
;
: UD.R  ( ud n -- )
	>r  (ud.)  r> over - spaces type
;
: (D.)  ( d -- c-addr cnt )
	tuck dabs <# #s rot sign #>
;
: D.    ( d -- )
	(d.)  type space
;
: D.R   ( d n -- , right justified )
	>r  (d.)  r>  over - spaces  type
;

: (U.)  ( u -- c-addr cnt )
	0 (ud.)
;
: U.    ( u -- , print unsigned number )
	0 ud.
;
: U.R   ( u n -- , print right justified )
	>r  (u.)  r> over - spaces  type
;
: (.)   ( n -- c-addr cnt )
	dup abs 0 <# #s rot sign #>
;
: .R    ( n l -- , print right justified)
	>r  (.)  r> over - spaces type
;


INIT-SER doesn't need to have a dictionary entry.

\ serCM3_sapi_level0.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

\ Level 0 support, with WFI instead of pause.
\ The SAPI is a system call interace, so there is no blocking.
\ KEY requires blocking, so that must be implemented here.

\ Copyright (c) 2016, Robert Sexton.  All rights reserved.
\ Covered by the terms of the supplied Licence.txt file

only forth definitions

\ ==============
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.   This is
\ ** The simplest implementation level.

\ ****************
\ *S Configuration
\ ****************
\ *P Configuration is managed by the SAPI

target

\ ********************
\ *S Serial primitives
\ ********************
internal

: +FaultConsole	( -- )  ;
\ *G Because this is a polled driver, *\fo{+FaultConsole} for
\ ** fault handling is a *\fo{NOOP}. See *\i{Cortex/FaultCortex.fth}
\ ** for more details.

target

\ CODE (seremitfc)	\ char base --
\ This is a system call.

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run, or just does a WFI if no multitasker.
\ The only interesting thing is failure, or -1.  That means retry.
	begin
	2dup (seremitfc) dup 0 < \ char base ret t/f
	IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ char base ret
    0 >= until
    2drop
	;

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
\ * The system call wants     base len caddr
\ * and it returns the number of characters sent.
	>R  \ We'll use this a few times.
	begin
	2dup R@ (sertypefc)  dup >R \ caddr len ret
	- dup IF \ If there are still characters left
	  [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then]
	  swap R> + swap \ finish advancing the caddr len pair
	ELSE R> drop
	THEN
	dup 0= until \ Do this until nothing is left.
	2drop
	R> drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
\ Wrapped version, just like (seremit)
	begin
	dup (sercrfc) dup 0= \ base ret t/f
    IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ base ret
    until
    drop
	;

: (serkey) \ base -- c
\ *G Get a character from the port.  Retry until we get it.
\ See if its negative.  If so, discard it and leave false to re-loop.
\ If not negative, leave true on the stack to exit.
    begin \ base ret t/f
	dup (serkeyfc) dup 0 <  \ base ret t/f
	 IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] drop false
	 ELSE true
	 THEN \ base ret t/f
	until  \ base ret
	swap drop
;

\ THis is a system call.
\ CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.

external

: seremit0	\ char --
\ *G Transmit a character on UART0.
  0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  0 (serkey)  ;
create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line

\ Non-UARTs.
: seremit10 #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

console-port  #10 = [if]
  console10 constant console
[then]

\ ************************
\ *S System initialisation
\ ************************

internal
\ This is a NOP in the SAPI environment
: init-ser ;	\ --
\ *G Initialise all serial ports
external

\ ======
\ *> ###
\ ======

decimal

\ serCM3_sapi_level0.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

\ Level 0 support, with WFI instead of pause.
\ The SAPI is a system call interace, so there is no blocking.
\ KEY requires blocking, so that must be implemented here.

\ Copyright (c) 2016, Robert Sexton.  All rights reserved.
\ Covered by the terms of the supplied Licence.txt file

only forth definitions

\ ==============
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.   This is
\ ** The simplest implementation level.

\ ****************
\ *S Configuration
\ ****************
\ *P Configuration is managed by the SAPI

target

\ ********************
\ *S Serial primitives
\ ********************
internal

: +FaultConsole	( -- )  ;
\ *G Because this is a polled driver, *\fo{+FaultConsole} for
\ ** fault handling is a *\fo{NOOP}. See *\i{Cortex/FaultCortex.fth}
\ ** for more details.

target

\ CODE (seremitfc)	\ char base --
\ This is a system call.

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run, or just does a WFI if no multitasker.
\ The only interesting thing is failure, or -1.  That means retry.
	begin
	2dup (seremitfc) dup 0 < \ char base ret t/f
	IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ char base ret
    0 >= until
    2drop
	;

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
\ * The system call wants     base len caddr
\ * and it returns the number of characters sent.
	>R  \ We'll use this a few times.
	begin
	2dup R@ (sertypefc)  dup >R \ caddr len ret
	- dup IF \ If there are still characters left
	  [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then]
	  swap R> + swap \ finish advancing the caddr len pair
	ELSE R> drop
	THEN
	dup 0= until \ Do this until nothing is left.
	2drop
	R> drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
\ Wrapped version, just like (seremit)
	begin
	dup (sercrfc) dup 0= \ base ret t/f
    IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] THEN \ base ret
    until
    drop
	;

: (serkey) \ base -- c
\ *G Get a character from the port.  Retry until we get it.
\ See if its negative.  If so, discard it and leave false to re-loop.
\ If not negative, leave true on the stack to exit.
    begin \ base ret t/f
	dup (serkeyfc) dup 0 <  \ base ret t/f
	 IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] drop false
	 ELSE true
	 THEN \ base ret t/f
	until  \ base ret
	swap drop
;

\ THis is a system call.
\ CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.

external

: seremit0	\ char --
\ *G Transmit a character on UART0.
  0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  0 (serkey)  ;
create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line

\ Non-UARTs.
: seremit10 #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

console-port  #10 = [if]
  console10 constant console
[then]

\ ************************
\ *S System initialisation
\ ************************

\ This is a NOP in the SAPI environment
: init-ser ;	\ --
\ *G Initialise all serial ports

\ ======
\ *> ###
\ ======

decimal


Re-grind the code.

Re-grind the code.

\ serCM3_sapi_p.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

((
Adapted from: the LPC polled driver.
))

only forth definitions
variable cnt.pause

\ ==============
\ *! serCM3_sapi_p
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.

\ ****************
\ *S Configuration
\ ****************
\ *P Configuration is managed by the SAPI

\ ********
\ *S Tools
\ ********

target

\ ********************
\ *S Serial primitives
\ ********************

internal

: +FaultConsole	( -- )  ;
\ *G Because this is a polled driver, *\fo{+FaultConsole} for
\ ** fault handling is a *\fo{NOOP}. See *\i{Cortex/FaultCortex.fth}
\ ** for more details.

target

CODE (seremitfc)	\ char base --
\ *G Service call for a single char - just fill in the registers
\ from the stack and make the call, and get back the flow control feedback
\ Put TOS into r0, pull r1 off the stack, and refresh the stack.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_PUTCHAR
	mov tos, r0
    next,
END-CODE

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run.  Count these events for debugging purposes.
	(seremitfc)
	0<> IF 1 cnt.pause +! #5 ms THEN
	;

: (sertype)	\ caddr len base --
\ *G Transmit a string on the given UART.
  -rot bounds
  ?do  i c@ over (seremit)  loop
  drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
  $0D over (seremit)  $0A swap (seremit)
;

CODE (sergetchar) \ base -- c
\ *G Get a character from the port
	mov r0, tos
	svc # SAPI_VEC_GETCHAR
	mov tos, r0
	next,
END-CODE

CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.
\ The call returns 0 or 1.
	mov r0, tos
	svc # SAPI_VEC_CHARSAVAIL
	mov tos, r0
	next,
END-CODE

: (serkey)	\ base -- char
\ *G Wait for a character to come available on the given UART and
\ ** return the character.
  begin
[ tasking? ] [if] pause [then]
  dup (serkey?)
  until
  (sergetchar)
;

external

: seremit0	\ char --
\ *G Transmit a character on UART0.
  0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  0 (serkey)  ;
create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line

\ UART2
: seremit2      #2 (seremit)  ;
: sertype2	#2 (sertype)  ;
: sercr2	#2 (sercr)  ;
: serkey?2	#2 (serkey?)  ;
: serkey2	#2 (serkey)  ;
create Console2 ' serkey2 , ' serkey?2 , ' seremit2 , ' sertype2 , ' sercr2 ,

\ Versions for use with the TCP Port (10)
: seremit10  #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

console-port #1 = [if]
  console1 constant console
[then]

console-port  #10 = [if]
  console10 constant console
[then]

\ ************************
\ *S System initialisation
\ ************************

\ This is a NOP in the SAPI environment
: init-ser ;	\ --
\ *G Initialise all serial ports

\ ======
\ *> ###
\ ======

decimal

\ serCM3_sapi_p.fth - SAPI polled RX, polled TX, serial communication drivers
\ Written to run against the SockPuppet API.

((
Adapted from: the LPC polled driver.
))

only forth definitions
variable cnt.pause

\ ==============
\ *! serCM3_sapi_p
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.

\ ****************
\ *S Configuration
\ ****************
\ *P Configuration is managed by the SAPI

\ ********
\ *S Tools
\ ********

target

\ ********************
\ *S Serial primitives
\ ********************

internal

: +FaultConsole	( -- )  ;
\ *G Because this is a polled driver, *\fo{+FaultConsole} for
\ ** fault handling is a *\fo{NOOP}. See *\i{Cortex/FaultCortex.fth}
\ ** for more details.

target

CODE (seremitfc)	\ char base --
\ *G Service call for a single char - just fill in the registers
\ from the stack and make the call, and get back the flow control feedback
\ Put TOS into r0, pull r1 off the stack, and refresh the stack.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_PUTCHAR
	mov tos, r0
    next,
END-CODE

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run.  Count these events for debugging purposes.
	(seremitfc)
	0<> IF 1 cnt.pause +! PAUSE THEN
	;

: (sertype)	\ caddr len base --
\ *G Transmit a string on the given UART.
  -rot bounds
  ?do  i c@ over (seremit)  loop
  drop
;

: (sercr)	\ base --
\ *G Transmit a CR/LF pair on the given UART.
  $0D over (seremit)  $0A swap (seremit)
;

CODE (sergetchar) \ base -- c
\ *G Get a character from the port
	mov r0, tos
	svc # SAPI_VEC_GETCHAR
	mov tos, r0
	next,
END-CODE

CODE (serkey?)     \ base -- t/f
\ *G Return true if the given UART has a character avilable to read.
\ The call returns 0 or 1.
	mov r0, tos
	svc # SAPI_VEC_CHARSAVAIL
	mov tos, r0
	next,
END-CODE

: (serkey)	\ base -- char
\ *G Wait for a character to come available on the given UART and
\ ** return the character.
  begin
[ tasking? ] [if] pause [then]
  dup (serkey?)
  until
  (sergetchar)
;

external

: seremit0	\ char --
\ *G Transmit a character on UART0.
  0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  0 (serkey)  ;
create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line

\ UART2
: seremit2      #2 (seremit)  ;
: sertype2	#2 (sertype)  ;
: sercr2	#2 (sercr)  ;
: serkey?2	#2 (serkey?)  ;
: serkey2	#2 (serkey)  ;
create Console2 ' serkey2 , ' serkey?2 , ' seremit2 , ' sertype2 , ' sercr2 ,

\ Versions for use with the TCP Port (10)
: seremit10  #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,

console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

console-port #1 = [if]
  console1 constant console
[then]

console-port  #10 = [if]
  console10 constant console
[then]

\ ************************
\ *S System initialisation
\ ************************

\ This is a NOP in the SAPI environment
: init-ser ;	\ --
\ *G Initialise all serial ports

\ ======
\ *> ###
\ ======

decimal


Float FIX uses FROUND

Float FIX uses FROUND

\ Floating point words from HMSL redefined using ANSI Forth
\
\ Author: Phil Burk
\ Copyright 2016 -  Phil Burk, Larry Polansky, David Rosenboom.
\ All Rights Reserved

ANEW TASK-FLOAT_PORT

: FPINIT ; \ not needed, floats always available
: FPTERM ;

: FMOD ( r1 r2 -f- rem{f1/f2} , calc remainder )
    fover fover f/
    f>s s>f
    f* f-
;

: F= ( r1 r2 -f- , -- flag )
    f- f0=
;

: F>  ( r1 r2 -f- , -- flag )
    fswap f<
;

: F>I ( r -f- , -- n )
    f>s
;

: FIX  ( r -f- , -- n , rounds )
    fround
;

: FLOAT ( n -- , -f- r , convert to float )
    s>f
;

: I>F ( n -- , -f- r , convert to float )
    s>f
;

: INT ( r -f- , -- n )
    f>s
;

: F>TEXT ( r -f- addr count , converts fp to text )
    (f.)
;

: F.R ( r -f- , width -- , set width of field, print )
    >r   \ save width
    (f.)
    r> over - spaces
    type
;

: PLACES ( n -- , sets default number of fractional digits )
    set-precision    \ this is not quite right, this sets significant digits
;

: FNUMBER? ( $string -- true | false , -f- r )
    number?       \ handles both ints and floats
;

\ Miscellaneous H4th words needed by HMSL.

ANEW TASK-H4TH_PORT

\ Floating point words redefined using ANSI Forth -------------

: FPINIT ; \ not needed, floats always available
: FPTERM ;

: FMOD ( r1 r2 -f- rem{f1/f2} , calc remainder )
    fover fover f/
    f>s s>f
    f* f-
;

: F= ( r1 r2 -f- , -- flag )
    f- f0=
;

: F>  ( r1 r2 -f- , -- flag )
    fswap f<
;

: F>I ( r -f- , -- n )
    f>s
;

: FIX  ( r -f- , -- n , rounds ) \ FROUND not implemented in pForth!
    0.5 f+ f>s
;

: FLOAT ( n -- , -f- r , convert to float )
    s>f
;

: I>F ( n -- , -f- r , convert to float )
    s>f
;

: INT ( r -f- , -- n )
    f>s
;

: F>TEXT ( r -f- addr count , converts fp to text )
    (f.)
;

: F.R ( r -f- , width -- , set width of field, print )
    >r   \ save width
    (f.)
    r> over - spaces
    type
;

: PLACES ( n -- , sets default number of fractional digits )
    set-precision    \ this is not quite right, this sets significant digits
;

: FNUMBER? ( $string -- true | false , -f- r )
    number?       \ handles both ints and floats
;


update example: check switch too

update example: check switch too

( LED flashing example
  Hardware: Lauchpad

  vi:ft=forth
)

INCLUDE msp430.forth
INCLUDE core.forth

CODE @B
    TOS->R15
    ." \t mov.b @R15, 0(TOS) " NL
    NEXT
END-CODE

CODE !B
    TOS->R14
    TOS->R15
    ." \t mov.b R14, 0(R15) " NL
    NEXT
END-CODE

CODE BIT_CLEAR_BYTE
    TOS->R14
    TOS->R15
    ." \t bic.b R14, 0(R15) " NL
    NEXT
END-CODE

CODE BIT_SET_BYTE
    TOS->R14
    TOS->R15
    ." \t bis.b R14, 0(R15) " NL
    NEXT
END-CODE

: INIT
    P1DIR [ BIT0 BIT6 + LITERAL ] !B
    P1OUT 0 !B
(    10 12 >
    IF 10 ELSE 20 ENDIF
    DROP
)
;

CODE DELAY
    TOS->R15
    ." .loop: \t dec R15 \n "
    ." \t jnz .loop \n "
    NEXT
END-CODE

( Control the LEDs on the Launchpad )
: RED_ON    P1OUT BIT0 BIT_SET_BYTE ;
: RED_OFF   P1OUT BIT0 BIT_CLEAR_BYTE ;
: GREEN_ON  P1OUT BIT6 BIT_SET_BYTE ;
: GREEN_OFF P1OUT BIT6 BIT_CLEAR_BYTE ;

( Read in the button on the Launchpad )
: S2        P1IN  @B BIT3 & NOT ;

: MAIN
    BEGIN
        ( Red flashing )
        RED_ON
        0xffff DELAY
        RED_OFF
        0xffff DELAY

        ( Green flashing if button is pressed )
        S2 IF
            GREEN_ON
            0x4fff DELAY
            GREEN_OFF
            0x4fff DELAY
        ENDIF
    LOOP
;

( ========================================================================= )
( Generate the assembler file now )
" LED example " HEADER

( output important runtime core parts )
" Core " HEADER
CROSS-COMPILE-CORE

( cross compile application )
" Application " HEADER
CROSS-COMPILE INIT
CROSS-COMPILE MAIN
CROSS-COMPILE-MISSING

( vi:ft=forth )

INCLUDE msp430.forth
INCLUDE core.forth

CODE !B
    TOS->R14
    TOS->R15
    ." \t mov.b R14, 0(R15) " NL
    NEXT
END-CODE

CODE BIT_CLEAR_BYTE
    TOS->R14
    TOS->R15
    ." \t bic.b R14, 0(R15) " NL
    NEXT
END-CODE

CODE BIT_SET_BYTE
    TOS->R14
    TOS->R15
    ." \t bis.b R14, 0(R15) " NL
    NEXT
END-CODE

: INIT
    P1DIR [ BIT0 BIT6 + LITERAL ] !B
    P1OUT 0 !B
    0 IF 10 ELSE 20 ENDIF
;

CODE DELAY
    TOS->R15
    ." .loop: \t dec R15 \n "
    ." \t jnz .loop \n "
    NEXT
END-CODE

: RED_ON    P1OUT BIT0 BIT_SET_BYTE ;
: RED_OFF   P1OUT BIT0 BIT_CLEAR_BYTE ;
: GREEN_ON  P1OUT BIT6 BIT_SET_BYTE ;
: GREEN_OFF P1OUT BIT6 BIT_CLEAR_BYTE ;

: MAIN
    BEGIN
        RED_ON
        0xffff DELAY
        RED_OFF
        0xffff DELAY
        GREEN_ON
        0x4fff DELAY
        GREEN_OFF
        0x4fff DELAY
    LOOP
;

( ========================================================================= )
( Generate the assembler file now )
" LED example " HEADER

( output important runtime core parts )
" Core " HEADER
CROSS-COMPILE-CORE

( cross compile application )
" Application " HEADER
CROSS-COMPILE INIT
CROSS-COMPILE MAIN
CROSS-COMPILE-MISSING