Re-factor the basic clock stuff.

Re-factor the basic clock stuff.

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

  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_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 or ;

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

(( 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
create NEEDLE_MAX #850 , #850 , #850 ,
cdata

: rangecheck ( max n -- n or zero ) dup >R <= if R> drop 0 else R> then ;

: ++NEEDLE_S \ Called every time.
    odn_hms    odn.s   \ Stash this address for the moment.

	needle_max odn.s @ \ Get the max
	over w@             \ Current value

	interp_hms interp.a interp-next + \ Returns a value.

	\ If we've wrapped to zero, reset the interpolator
	\ so that we don't accumulate errors during setting/
	\ calibration operations.
    rangecheck dup  0= if  interp_hms interp.a  interp-reset  then
	swap w!
	;

: ++NEEDLE_DS ; \ Called every time.

: ++NEEDLE_M ; \ Every time we roll the seconds.
: ++NEEDLE_DM ; \ Every time we roll the seconds.

: _USE ( odn-addr -- )
  dup w@ pwm0!
  dup 2 + w@ pwm1!
  4 + 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

  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_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 or ;

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


LOG2 ( n -- n log2_n ) -> ( n -- log2_n )

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

\ test if the top is a negative number
: ?NEG ( n -- bool ) DUP 0= IF -1 ELSE DUP ABS <> THEN ;

\ log2 (integer)
: LOG2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Log2 need a positive value."
                                 ELSE DUP 1 = IF 0
                                              ELSE
                                                  1 >R
                                                  BEGIN ( n |R: i)
                                                      DUP DUP 2 I ( n n n 2 i |R: i)
                                                      ** ( n n n 2**i )
                                                      - ( n n n-2**i )
                                                      2 * ( n n 2*[n-2**i])
                                                      R> 1 + >R ( … |R: i+1)
                                                      > ( n n>2*[n-2**i] )
                                                  UNTIL
                                                  R> 1 -
                                              THEN
                                 THEN NIP ;

\ decimal to binary
\ e.g. : ( 11 -- 1 0 1 1 )
\ FIXME n DEC2BIN seems to give the binary value of n-1
: DEC2BIN ( n -- n1 n2 n3 … ) DUP LOG2 2 SWAP ** >R ( n |R: X = 2 ** n.log2 )
                                BEGIN
                                    DUP I - 0 > IF 1 SWAP I - ( 1 n-X )
                                                ELSE 0 SWAP   ( 0 n )
                                                THEN
                                    I 1 =
                                    R> 2 / >R ( … | X/2 )
                                UNTIL
                                R> 2DROP
                                ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 1011 -> -1
\        1001 -> 0
: ?TWO-ADJACENT-1-BITS ( n -- bool ) ( TODO ) ;

\ return the maximum number which can be made with N (given number) bits
: ?MAX-NB ( n -- m ) DUP ?NEG 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 ;

\ test if the top is a negative number
: ?NEG ( n -- bool ) DUP 0= IF -1 ELSE DUP ABS <> THEN ;

\ log2 (integer)
: LOG2 ( n -- n log2_n ) DUP 1 < IF 1 ABORT" Log2 need a positive value."
                                 ELSE DUP 1 = IF 0
                                              ELSE
                                                  1 >R
                                                  BEGIN ( n |R: i)
                                                      DUP DUP 2 I ( n n n 2 i |R: i)
                                                      ** ( n n n 2**i )
                                                      - ( n n n-2**i )
                                                      2 * ( n n 2*[n-2**i])
                                                      R> 1 + >R ( … |R: i+1)
                                                      > ( n n>2*[n-2**i] )
                                                  UNTIL
                                                  R> 1 -
                                              THEN
                                 THEN ;

\ decimal to binary
\ e.g. : ( 11 -- 1 0 1 1 )
\ FIXME n DEC2BIN seems to give the binary value of n-1
: DEC2BIN ( n -- n1 n2 n3 … ) DUP LOG2 2 SWAP ** >R ( n |R: X = 2 ** n.log2 )
                                BEGIN
                                    DUP I - 0 > IF 1 SWAP I - ( 1 n-X )
                                                ELSE 0 SWAP   ( 0 n )
                                                THEN
                                    I 1 =
                                    R> 2 / >R ( … | X/2 )
                                UNTIL
                                R> 2DROP
                                ;

\ -- kata

\ test if the given N has two adjacent 1 bits
\ e.g. : 1011 -> -1
\        1001 -> 0
: ?TWO-ADJACENT-1-BITS ( n -- bool ) ( TODO ) ;

\ return the maximum number which can be made with N (given number) bits
: ?MAX-NB ( n -- m ) DUP ?NEG 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 ) ;


MAXPOW2 implemented, LOG2 removed

MAXPOW2 implemented, LOG2 removed

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

\ test if the top is a negative number
: ?NEG ( n -- bool ) DUP 0= IF -1 ELSE DUP ABS <> THEN ;

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

\ test if the top is a negative number
: ?NEG ( n -- bool ) DUP 0= IF -1 ELSE DUP ABS <> THEN ;

\ log2 (integer)
\ TODO remove this word, and add a new word
\ which compute the value of ( n LOG2 2 SWAP ** )
: LOG2 ( n -- log2_n ) DUP 1 < IF 1 ABORT" Log2 need a positive value."
                               ELSE DUP 1 = IF 0
                                            ELSE
                                                1 >R
                                                BEGIN ( n |R: i=1)
                                                    DUP DUP 2 I ** - 2 *
                                                    ( n n 2*[n-2**i])
                                                    R> 1 + >R ( … |R: i+1)
                                                    > ( n n>2*[n-2**i] )
                                                UNTIL
                                                R> 1 -
                                            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
                            LOG2 2 SWAP ** >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 ?NEG 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 ) ;


asm label prefix

asm label prefix

( Implementations of builtins.
  These functions are provided for the host in the msp430.asm.forth module. The
  implementations here are for the target.

  vi:ft=forth
)

( ----- low level supporting functions ----- )

CODE LIT
    ." \t decd TOS         ; prepare push on stack \n "
    ." \t mov @IP+, 0(TOS) ; copy value from thread to stack \n "
    NEXT
END-CODE

CODE BRANCH
    ." \t add @IP+, IP \n "
    ." \t decd IP \n "
    NEXT
END-CODE-INTERNAL

CODE BRANCH0
    ." \t mov @IP+, W ; get offset \n "
    ." \t tst 0(TOS)  ; check TOS \n "
    ." \t jnz .Lnjmp  ; skip next if non zero \n "
    ." \t decd IP     ; offset is relative to position of offset, correct \n "
    ." \t add W, IP   ; adjust IP \n "
." .Lnjmp: "
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Stack ops ----- )

CODE DROP
    ." \t incd TOS " NL
    NEXT
END-CODE-INTERNAL

CODE DUP
    ." \t decd TOS " NL
    ." \t mov 2(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE OVER
    ." \t decd TOS " NL
    ." \t mov 4(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( Push a copy of the N'th element )
CODE PICK ( n - n )
    TOS->R15                    ( get element number from stack )
    ." \t rla R15 " NL          ( multiply by 2 -> 2 byte / cells )
    ." \t add TOS, R15 " NL     ( calculate address on stack )
    ." \t decd TOS " NL         ( push copy )
    ." \t mov 0(R15), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE SWAP ( y x - x y )
    ." \t mov 2(TOS), W " NL
    ." \t mov 0(TOS), 2(TOS) " NL
    ." \t mov W, 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( ----- MATH ----- )

CODE +
    ." \t add 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE -
    ." \t sub 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- bit - ops ----- )
CODE &
    ." \t and 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE |
    ." \t bis 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ^
    ." \t xor 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ~
    ." \t inv 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Logic ops ----- )
( include normalize to boolean )

CODE NOT
    ." \t tst 0(TOS) " NL
    ." \t jnz .not0 " NL
    ." \t mov \x23 -1, 0(TOS) " NL       ( replace TOS w/ result )
    ." \t jmp .not2 " NL
    ." .not0: " NL
    ." \t mov \x23 0, 0(TOS) " NL       ( replace TOS w/ result )
    ." .not2: " NL
    NEXT
END-CODE-INTERNAL

( ---------------------------------------------------
    "MIN" """Leave the smaller of two values on the stack"""
    "MAX" """Leave the larger of two values on the stack"""
    "*"
    "/"
    "NEG"
    "<<"
    ">>"
    "NOT"
    "AND"
    "OR"
)
( ----- Compare ----- )
CODE cmp_set_true   ( n - n )
    ." \t mov \x23 -1, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_set_false
    ." \t mov \x23 0, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_true
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 -1, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE cmp_false
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 0, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE <
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  _cmp_true " NL
    ." \t jmp _cmp_false " NL
END-CODE-INTERNAL

CODE >
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  _cmp_false " NL
    ." \t jmp _cmp_true " NL
END-CODE-INTERNAL

CODE <=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge _cmp_false " NL
    ." \t jmp _cmp_true " NL
END-CODE-INTERNAL

CODE >=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge _cmp_true " NL
    ." \t jmp _cmp_false " NL
END-CODE-INTERNAL

CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq _cmp_true " NL
    ." \t jmp _cmp_false " NL
END-CODE-INTERNAL

( XXX alias for == )
CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq _cmp_true " NL
    ." \t jmp _cmp_false " NL
END-CODE-INTERNAL

CODE !=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jne _cmp_true " NL
    ." \t jmp _cmp_false " NL
END-CODE-INTERNAL

CODE 0=
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jz  _cmp_set_true " NL
    ." \t jmp _cmp_set_false " NL
END-CODE-INTERNAL

CODE 0>
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jn  _cmp_set_false " NL
    ." \t jmp _cmp_set_true " NL
END-CODE-INTERNAL

( Implementations of builtins.
  These functions are provided for the host in the msp430.asm.forth module. The
  implementations here are for the target.

  vi:ft=forth
)

( ----- low level supporting functions ----- )

CODE LIT
    ." \t decd TOS         ; prepare push on stack \n "
    ." \t mov @IP+, 0(TOS) ; copy value from thread to stack \n "
    NEXT
END-CODE

CODE BRANCH
    ." \t add @IP+, IP \n "
    ." \t decd IP \n "
    NEXT
END-CODE-INTERNAL

CODE BRANCH0
    ." \t mov @IP+, W ; get offset \n "
    ." \t tst 0(TOS)  ; check TOS \n "
    ." \t jnz .Lnjmp  ; skip next if non zero \n "
    ." \t decd IP     ; offset is relative to position of offset, correct \n "
    ." \t add W, IP   ; adjust IP \n "
." .Lnjmp: "
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Stack ops ----- )

CODE DROP
    ." \t incd TOS " NL
    NEXT
END-CODE-INTERNAL

CODE DUP
    ." \t decd TOS " NL
    ." \t mov 2(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE OVER
    ." \t decd TOS " NL
    ." \t mov 4(TOS), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( Push a copy of the N'th element )
CODE PICK ( n - n )
    TOS->R15                    ( get element number from stack )
    ." \t rla R15 " NL          ( multiply by 2 -> 2 byte / cells )
    ." \t add TOS, R15 " NL     ( calculate address on stack )
    ." \t decd TOS " NL         ( push copy )
    ." \t mov 0(R15), 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

CODE SWAP ( y x - x y )
    ." \t mov 2(TOS), W " NL
    ." \t mov 0(TOS), 2(TOS) " NL
    ." \t mov W, 0(TOS) " NL
    NEXT
END-CODE-INTERNAL

( ----- MATH ----- )

CODE +
    ." \t add 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE -
    ." \t sub 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- bit - ops ----- )
CODE &
    ." \t and 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE |
    ." \t bis 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ^
    ." \t xor 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

CODE ~
    ." \t inv 0(TOS), 2(TOS) " NL
    DROP-ASM
    NEXT
END-CODE-INTERNAL

( ----- Logic ops ----- )
( include normalize to boolean )

CODE NOT
    ." \t tst 0(TOS) " NL
    ." \t jnz .not0 " NL
    ." \t mov \x23 -1, 0(TOS) " NL       ( replace TOS w/ result )
    ." \t jmp .not2 " NL
    ." .not0: " NL
    ." \t mov \x23 0, 0(TOS) " NL       ( replace TOS w/ result )
    ." .not2: " NL
    NEXT
END-CODE-INTERNAL

( ---------------------------------------------------
    "MIN" """Leave the smaller of two values on the stack"""
    "MAX" """Leave the larger of two values on the stack"""
    "*"
    "/"
    "NEG"
    "<<"
    ">>"
    "NOT"
    "AND"
    "OR"
)
( ----- Compare ----- )
CODE cmp_set_true   ( n - n )
    ." \t mov \x23 -1, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_set_false
    ." \t mov \x23 0, 0(TOS) " NL   ( replace argument w/ result )
    NEXT
END-CODE

CODE cmp_true
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 -1, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE cmp_false
    DROP-ASM                        ( remove 1nd argument )
    ." \t mov \x23 0, 0(TOS) " NL   ( replace 2nd argument w/ result )
    NEXT
END-CODE

CODE <
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE >
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jl  cmp_false " NL
    ." \t jmp cmp_true " NL
END-CODE-INTERNAL

CODE <=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge cmp_false " NL
    ." \t jmp cmp_true " NL
END-CODE-INTERNAL

CODE >=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jge cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

( XXX alias for == )
CODE ==
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jeq cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE !=
    DEPENDS-ON cmp_true
    DEPENDS-ON cmp_false
    ." \t cmp 0(TOS), 2(TOS) " NL
    ." \t jne cmp_true " NL
    ." \t jmp cmp_false " NL
END-CODE-INTERNAL

CODE 0=
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jz  cmp_set_true " NL
    ." \t jmp cmp_set_false " NL
END-CODE-INTERNAL

CODE 0>
    DEPENDS-ON cmp_set_true
    DEPENDS-ON cmp_set_false
    ." \t tst 0(TOS) " NL
    ." \t jn  cmp_set_false " NL
    ." \t jmp cmp_set_true " NL
END-CODE-INTERNAL


Make wake support a compile-time selection.

\ Wrappers for SAPI functions, ABI 4.0

\ Note that the system call number is embedded into the instruction,
\ so this is not so easily parameterized.

#0 equ SAPI_VEC_VERSION
#1 equ SAPI_VEC_01_GetRuntimeLinks
#2 equ SAPI_VEC_02_PutChar
#3 equ SAPI_VEC_03_GetChar
#4 equ SAPI_VEC_04_GetCharAvail
#5 equ SAPI_VEC_05_PutString
#6 equ SAPI_VEC_06_EOL
#14 equ SAPI_VEC_14_PetWatchdog
#15 equ SAPI_VEC_15_GetTimeMS

CODE SAPI-Version  \ -- n
\ *G Get the version of the binary ABI in use.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE GETRUNTIMELINKS  \ type -- n
\ *G Get the runtime linking information.   Type 0 - A Dynamic linking
\ ** table with name, address pairs.  Type 1 - A Zero-Terminated Jump table.
	mov r0, tos
	svc # SAPI_VEC_01_GetRuntimeLinks
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE (seremitfc) \ char base --
\ *G Service call for a single char - This one has a special name because
\ ** It'll be wrapped by something that can respond to the flow control
\ ** return code and PAUSE + Retry
	mov r0, tos
	ldr r1, [ psp ], # 4
	[defined] SAPIWakeSupport? [if] mov r2, up [else] mov r2, # 0 [then]
	svc # SAPI_VEC_02_PutChar
	mov tos, r0
    next,
END-CODE

CODE (serkeyfc) \ base -- char
\ *G Get a character from the port, or -1 for fail
	mov r0, tos
	[defined] SAPIWakeSupport? [if] mov r1, up [else] mov r1, # 0 [then]
	svc # SAPI_VEC_03_GetChar
	mov tos, r0
	next,
END-CODE

CODE (serkey?) \ base -- t/f
\ *G Return true if the given stream has a character avilable to read.
\ The call returns the number of chars available.
	mov r0, tos
	svc # SAPI_VEC_04_GetCharAvail
	mov tos, r0
	next,
END-CODE

CODE (sercrfc) \ base -- return
\ *G Send a line terminator to the port.  Return 0 for success, -1 for fail.
	mov r0, tos
	[defined] SAPIWakeSupport? [if] mov r1, up [else] mov r1, # 0 [then]
	svc # SAPI_VEC_06_EOL
	mov tos, r0
	next,
END-CODE

\ These two can be created from simpler things, and are optional.
\ CODE (type)
\ END-CODE

\ CODE (cr)
\ END-CODE

CODE PetWatchDog  \ n --
\ *G Refresh the watchdog.  Pass in a platform-specific number
\ ** To specify a timerout (if supported), or zero for the default value.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_14_PetWatchdog
	ldr tos, [ psp ], # 4
	next,
END-CODE

CODE TICKS  \ -- n
\ *G The current value of the millisecond ticker.
    mov r0, # 0 \ We want the actual value.
	svc # SAPI_VEC_15_GetTimeMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ Wrappers for SAPI functions, ABI 4.0

\ Note that the system call number is embedded into the instruction,
\ so this is not so easily parameterized.

#0 equ SAPI_VEC_VERSION
#1 equ SAPI_VEC_01_GetRuntimeLinks
#2 equ SAPI_VEC_02_PutChar
#3 equ SAPI_VEC_03_GetChar
#4 equ SAPI_VEC_04_GetCharAvail
#5 equ SAPI_VEC_05_PutString
#6 equ SAPI_VEC_06_EOL
#14 equ SAPI_VEC_14_PetWatchdog
#15 equ SAPI_VEC_15_GetTimeMS

CODE SAPI-Version  \ -- n
\ *G Get the version of the binary ABI in use.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE GETRUNTIMELINKS  \ type -- n
\ *G Get the runtime linking information.   Type 0 - A Dynamic linking
\ ** table with name, address pairs.  Type 1 - A Zero-Terminated Jump table.
	mov r0, tos
	svc # SAPI_VEC_01_GetRuntimeLinks
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE (seremitfc) \ char base --
\ *G Service call for a single char - This one has a special name because
\ ** It'll be wrapped by something that can respond to the flow control
\ ** return code and PAUSE + Retry
	mov r0, tos
	ldr r1, [ psp ], # 4
	mov r2, # 0 \ Don't request a wake.
	svc # SAPI_VEC_02_PutChar
	mov tos, r0
    next,
END-CODE

CODE (serkeyfc) \ base -- char
\ *G Get a character from the port, or -1 for fail
	mov r0, tos
	mov r1, up \ Block!
	svc # SAPI_VEC_03_GetChar
	mov tos, r0
	next,
END-CODE

CODE (serkey?) \ base -- t/f
\ *G Return true if the given stream has a character avilable to read.
\ The call returns the number of chars available.
	mov r0, tos
	svc # SAPI_VEC_04_GetCharAvail
	mov tos, r0
	next,
END-CODE

CODE (sercrfc) \ base -- return
\ *G Send a line terminator to the port.  Return 0 for success, -1 for fail.
	mov r0, tos
	mov r1, up \ Block!
	svc # SAPI_VEC_06_EOL
	mov tos, r0
	next,
END-CODE

\ These two can be created from simpler things, and are optional.
\ CODE (type)
\ END-CODE

\ CODE (cr)
\ END-CODE

CODE PetWatchDog  \ n --
\ *G Refresh the watchdog.  Pass in a platform-specific number
\ ** To specify a timerout (if supported), or zero for the default value.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_14_PetWatchdog
	ldr tos, [ psp ], # 4
	next,
END-CODE

CODE TICKS  \ -- n
\ *G The current value of the millisecond ticker.
    mov r0, # 0 \ We want the actual value.
	svc # SAPI_VEC_15_GetTimeMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE


LOG2 tests removed, MAXPOW2 tests added

LOG2 tests removed, MAXPOW2 tests added

\ KataDiversion tests, in Forth
\ running tests:
\   gforth KataDiversion_tests.fth -e bye

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT

: ASSERTS-INIT ( -- )
    0 ASSERT-COUNT ! ;

: ASSERTS-RESULT ( -- )
    ASSERT-COUNT @ . ." assertions successfully passed." CR ;

\ destructive assert-equal
: ASSERT-EQUAL-D ( n1 n2 -- )
    <> IF 1 ABORT" AssertEqual: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-equal
: ASSERT-EQUAL ( n1 n2 -- n1 n2 )
    2DUP ASSERT-EQUAL-D ;

\ destructive assert-true
: ASSERT-TRUE-D ( n -- )
    0 = IF 1 ABORT" AssertTrue: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-true
: ASSERT-TRUE ( n -- n )
    DUP ASSERT-TRUE-D ;

\ destructive assert-false
: ASSERT-False-D ( n -- )
    0 <> IF 1 ABORT" AssertFalse: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-false
: ASSERT-FALSE ( n -- n )
    DUP ASSERT-FALSE-D ;

\ ---- tests ----

ASSERTS-INIT

\ ?EMPTY
EMPTY         DEPTH 0 ASSERT-EQUAL-D
EMPTY EMPTY   DEPTH 0 ASSERT-EQUAL-D
0 EMPTY       DEPTH 0 ASSERT-EQUAL-D
1 2 3 4 EMPTY DEPTH 0 ASSERT-EQUAL-D

\ ?NEGATIVE
-1 ?NEG ASSERT-TRUE-D
 0 ?NEG ASSERT-TRUE-D
 1 ?NEG ASSERT-FALSE-D

\ ?MAX-NB
-1 ?MAX-NB  0   ASSERT-EQUAL-D
 0 ?MAX-NB  0   ASSERT-EQUAL-D
 1 ?MAX-NB  2   ASSERT-EQUAL-D
 2 ?MAX-NB  4   ASSERT-EQUAL-D
 3 ?MAX-NB  8   ASSERT-EQUAL-D

\ MAXPOW2
   1 MAXPOW2     1 ASSERT-EQUAL-D
   2 MAXPOW2     2 ASSERT-EQUAL-D
   3 MAXPOW2     2 ASSERT-EQUAL-D
   4 MAXPOW2     4 ASSERT-EQUAL-D
   5 MAXPOW2     4 ASSERT-EQUAL-D
   8 MAXPOW2     8 ASSERT-EQUAL-D
  42 MAXPOW2    32 ASSERT-EQUAL-D
2000 MAXPOW2  1024 ASSERT-EQUAL-D

\ ?TWO-ADJACENT-1-BITS
   1 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
   2 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
   3 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
   6 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
   7 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
   8 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
  11 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
  65 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
3072 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D

ASSERTS-RESULT
\ ---------

\ KataDiversion tests, in Forth
\ running tests:
\   gforth KataDiversion_tests.fth -e bye

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT

: ASSERTS-INIT ( -- )
    0 ASSERT-COUNT ! ;

: ASSERTS-RESULT ( -- )
    ASSERT-COUNT @ . ." assertions successfully passed." CR ;

\ destructive assert-equal
: ASSERT-EQUAL-D ( n1 n2 -- )
    <> IF 1 ABORT" AssertEqual: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-equal
: ASSERT-EQUAL ( n1 n2 -- n1 n2 )
    2DUP ASSERT-EQUAL-D ;

\ destructive assert-true
: ASSERT-TRUE-D ( n -- )
    0 = IF 1 ABORT" AssertTrue: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-true
: ASSERT-TRUE ( n -- n )
    DUP ASSERT-TRUE-D ;

\ destructive assert-false
: ASSERT-False-D ( n -- )
    0 <> IF 1 ABORT" AssertFalse: Fail"
            ELSE ASSERT-COUNT @ 1+ ASSERT-COUNT ! THEN ;

\ non-destructive assert-false
: ASSERT-FALSE ( n -- n )
    DUP ASSERT-FALSE-D ;

\ ---- tests ----

ASSERTS-INIT

\ ?EMPTY
EMPTY         DEPTH 0 ASSERT-EQUAL-D
EMPTY EMPTY   DEPTH 0 ASSERT-EQUAL-D
0 EMPTY       DEPTH 0 ASSERT-EQUAL-D
1 2 3 4 EMPTY DEPTH 0 ASSERT-EQUAL-D

\ ?NEGATIVE
-1 ?NEG ASSERT-TRUE-D
 0 ?NEG ASSERT-TRUE-D
 1 ?NEG ASSERT-FALSE-D

\ ?MAX-NB
-1 ?MAX-NB  0   ASSERT-EQUAL-D
 0 ?MAX-NB  0   ASSERT-EQUAL-D
 1 ?MAX-NB  2   ASSERT-EQUAL-D
 2 ?MAX-NB  4   ASSERT-EQUAL-D
 3 ?MAX-NB  8   ASSERT-EQUAL-D

\ LOG2
 1 LOG2  0 ASSERT-EQUAL-D
 2 LOG2  1 ASSERT-EQUAL-D
 3 LOG2  1 ASSERT-EQUAL-D
 4 LOG2  2 ASSERT-EQUAL-D
 5 LOG2  2 ASSERT-EQUAL-D
 8 LOG2  3 ASSERT-EQUAL-D
42 LOG2  5 ASSERT-EQUAL-D

   1 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
   2 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
   3 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
   6 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
   7 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
   8 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
  11 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D
  65 ?TWO-ADJACENT-1-BITS  0 ASSERT-EQUAL-D
3072 ?TWO-ADJACENT-1-BITS -1 ASSERT-EQUAL-D

ASSERTS-RESULT
\ ---------


Fix duplicate code and bottom-right-valid constraint.

3 constant width
21 constant goal
width 1- constant wm
width 1+ constant wp
width width * constant size

create choices  3 ,  4 ,  5 ,
                6 ,  7 ,  8 ,
                9 , 10 , 11 ,

variable picked size allot
variable additional-constraints size cells allot

: clear-picked
    size
    begin
        1- dup 0>= while
            dup picked + 0 swap C!
    repeat
    drop ;

: print-picked
    9 0 do
        i picked + C@ .
    loop ;

variable a size cells allot

: choice-search
    0
    begin
        dup size < while
            choices over cells + @
            rot tuck = if
                drop -1 exit
            endif
            swap 1+
    repeat
    2drop 0 ;

: reverse-cross-valid
    0
    wm wp * wm do
        a i cells + @ +
    wm +loop
    goal = ;

: cross-valid
    0
    size 0 do
        a i cells + @ +
    wp +loop
    goal = ;

: bottom-row-valid
    0
    size size width - do
        a i cells + @ +
    loop
    goal = ;

: bottom-right-valid
    bottom-row-valid if
        cross-valid
    else
        0
    endif ;

0 VALUE pick-next-ref

: execute-predicate?
    dup 0<> if
        execute
    else
        drop -1
    endif ;

: pick-internal
    size 0 do
        dup cells a + choices i cells + @ swap !
        i picked + C@ 0= if
            dup cells additional-constraints + @ execute-predicate? if
                1 i picked + C!
                dup pick-next-ref execute
                0 i picked + C!
            endif
        endif
    loop
    drop ;

: pick-right
    0 over dup dup width mod - do
        a i cells + @ +
    loop
    goal swap -
    over over swap cells a + !
    choice-search if
        dup picked + C@ 0= if
            over cells additional-constraints + @ execute-predicate? if
                1 over picked + C!
                over pick-next-ref execute
                0 swap picked + C!
            else
                drop
            endif
        else
            drop
        endif
    endif
    drop ;

: pick-bottom
    0 over dup width mod do
        a i cells + @ +
    width +loop
    goal swap -
    over over swap cells a + !
    choice-search if
        dup picked + C@ 0= if
            over cells additional-constraints + @ execute-predicate? if
                1 over picked + C!
                over pick-next-ref execute
                0 swap picked + C!
            else
                drop
            endif
        else
            drop
        endif
    endif
    drop ;

create solution-count 0 ,

: solution
    solution-count @ 1+ dup solution-count !
    ." --- Solution " . ." ---" CR
    size 0 do
        a i cells + @ .
        i 3 mod 2 = if CR endif
    loop ;

: print-right-internal
    dup width mod wm = if
        ." pick-right " .
    else
        ." pick-internal " .
    endif ;

: print-next
    dup . ." -> "
    dup size 1- = if
        drop ." solution"
    else
        dup width wm * >= if
            wm -
            print-right-internal
        else
            dup width dup 2 - * >= if
                width +
                ." pick-bottom " .
            else
                1+
                print-right-internal
            endif
        endif
    endif ;

: pick-right-internal
    dup width mod wm = if
        pick-right
    else
        pick-internal
    endif ;

: pick-next
    dup size 1- = if
        drop solution
    else
        dup width wm * >= if
            wm -
            pick-right-internal
        else
            dup width dup 2 - * >= if
                width +
                pick-bottom
            else
                1+
                pick-right-internal
            endif
        endif
    endif ;

' pick-next TO pick-next-ref

: init-board
    size 0 do
        i 1+ a i cells + !
    loop ;

: clear-constraints
    size 0 do
        0 additional-constraints i cells + !
    loop ;

clear-constraints
' reverse-cross-valid additional-constraints size width - width - 1+ cells + !
' bottom-right-valid additional-constraints size 1- cells + !

: solve-puzzle
    clear-picked init-board 0 solution-count !
    0 pick-internal ;

3 constant width
21 constant goal
width 1- constant wm
width 1+ constant wp
width width * constant size

create choices  3 ,  4 ,  5 ,
                6 ,  7 ,  8 ,
                9 , 10 , 11 ,

variable picked size allot
variable additional-constraints size allot

: clear-picked
    size
    begin
        1- dup 0>= while
            dup picked + 0 swap C!
    repeat
    drop ;

: print-picked
    9 0 do
        i picked + C@ .
    loop ;

variable a size cells allot

: choice-search
    0
    begin
        dup size < while
            choices over cells + @
            rot tuck = if
                drop -1 exit
            endif
            swap 1+
    repeat
    2drop 0 ;

: reverse-cross-valid
    0
    wm wp * wm do
        a i cells + @ +
    wm +loop
    goal = ;

: cross-valid
    0
    size 0 do
        a i cells + @ +
    wp +loop
    goal = ;

: bottom-row-valid
    0
    size size width - do
        a i cells + @ +
    loop
    goal = ;

: bottom-right-valid
    bottom-row-valid if
        -1
    else
        cross-valid
    endif ;

0 VALUE pick-next-ref

: execute-predicate?
    dup 0<> if
        execute
    else
        drop -1
    endif ;

: pick-internal
    size 0 do
        dup cells a + choices i cells + @ swap !
        i picked + C@ 0= if
            dup cells additional-constraints + @ execute-predicate? if
                1 i picked + C!
                dup pick-next-ref execute
                0 i picked + C!
            endif
        endif
    loop
    drop ;

: pick-right
    0 over dup dup width mod - do
        a i cells + @ +
    loop
    goal swap -
    over over swap cells a + !
    choice-search if
        dup picked + C@ 0= if
            over cells additional-constraints + @ execute-predicate? if
                1 over picked + C!
                over pick-next-ref execute
                0 swap picked + C!
            else
                drop
            endif
            1 over picked + C!
            over pick-next-ref execute
            0 swap picked + C!
        else
            drop
        endif
    endif
    drop ;

: pick-bottom
    0 over dup width mod do
        a i cells + @ +
    width +loop
    goal swap -
    over over swap cells a + !
    choice-search if
        dup picked + C@ 0= if
            over cells additional-constraints + @ execute-predicate? if
                1 over picked + C!
                over pick-next-ref execute
                0 swap picked + C!
            else
                drop
            endif
        else
            drop
        endif
    endif
    drop ;

create solution-count 0 ,

: solution
    solution-count @ 1+ dup solution-count !
    ." --- Solution " . ." ---" CR
    size 0 do
        a i cells + @ .
        i 3 mod 2 = if CR endif
    loop ;

: print-right-internal
    dup width mod wm = if
        ." pick-right " .
    else
        ." pick-internal " .
    endif ;

: print-next
    dup . ." -> "
    dup size 1- = if
        drop ." solution"
    else
        dup width wm * >= if
            wm -
            print-right-internal
        else
            dup width dup 2 - * >= if
                width +
                ." pick-bottom " .
            else
                1+
                print-right-internal
            endif
        endif
    endif ;

: pick-right-internal
    dup width mod wm = if
        pick-right
    else
        pick-internal
    endif ;

: pick-next
    dup size 1- = if
        drop solution
    else
        dup width wm * >= if
            wm -
            pick-right-internal
        else
            dup width dup 2 - * >= if
                width +
                pick-bottom
            else
                1+
                pick-right-internal
            endif
        endif
    endif ;

' pick-next TO pick-next-ref

: init-board
    size 0 do
        i 1+ a i cells + !
    loop ;

: clear-constraints
    size 0 do
        0 additional-constraints i cells + !
    loop ;

clear-constraints
' reverse-cross-valid additional-constraints size width - width - 1+ cells + !
' bottom-right-valid additional-constraints size 1- cells + !

: solve-puzzle
    clear-picked init-board 0 solution-count !
    0 pick-internal ;


A better name.

A better name.


Postpone IS...

Postpone IS...

: (   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
    >body swap >size
    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

\ 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
        3 cell* +      \ offset to EXIT 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 )
        compile rdrop       \ drop a stack frame (call becomes goto)
        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 @ ;

: 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 ;
: 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= -13 ?ERROR
    0>
    IF compile,  \ immediate
    ELSE (compile)  \ normal
    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
;

: INCLUDE? ( <word> <file> -- , load file if word not defined )
        bl word find
        IF drop bl word drop  ( eat word from source )
        ELSE drop include
        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 +!
;

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

: (WARNING")  ( flag $message -- )
    swap
    IF count type
    ELSE drop
    THEN
;

: WARNING" ( flag <message> -- , print warning if true. )
	[compile] "  ( compile message )
	state @
	IF  compile (warning")
	ELSE (warning")
	THEN
; IMMEDIATE

: ABORT" ( flag <message> -- , print warning if true. )
	[compile] "  ( compile message )
	state @
	IF  compile (abort")
	ELSE (abort")
	THEN
; IMMEDIATE

: DEFER ( "name" -- )
   CREATE ['] ABORT ,
   DOES> ( ... -- ... ) @ EXECUTE ;

: DEFER! ( xt2 xt1 -- )
   >BODY 4 CELL* + ! ;

: DEFER@ ( xt1 -- xt2 )
   >BODY 4 CELL* + @ ;

\ : IS ( xt "<spaces>name" -- , Skip leading spaces and parse name delimited by a space. Set name to execute xt. )
\    STATE @ IF
\      POSTPONE ['] POSTPONE DEFER!
\    ELSE
\      ' DEFER!
\    THEN ; IMMEDIATE


Don’t configure the stack pointers in the forth startup.  It doesn’t know the big picture.

\ startSTM32F072.fth - Cortex startup code for SM32F072B-DISCO board
\ Customized for use with SockPuppet.  No hardware init code.

((

To do
=====

Change history
==============
))

only forth definitions  decimal

\ ===========
\ *! startstm32f072
\ *T Cortex start up for STM32F072
\ ===========

l: ExcVecs	\ -- addr ; start of vector table
\ *G The exception vector table is *\fo{/ExcVecs} bytes long. The
\ ** equate is defined in the control file. Note that this table
\ ** table must be correctly aligned as described in the Cortex-M3
\ ** Technical Reference Manual (ARM DDI0337, rev E page 8-21). If
\ ** placed at 0 or the start of Flash, you'll usually be fine.
  /ExcVecs allot&erase

interpreter
: SetExcVec	\ addr exc# --
\ *G Set the given exception vector number to the given address.
\ ** Note that for vectors other than 0, the Thumb bit is forced
\ ** to 1.
  dup if				\ If not the stack top
    swap 1 or swap			\   set the Thumb bit
  endif
  cells ExcVecs + !  ;
target

L: CLD1		\ holds xt of main word
  0 ,					\ fixed by MAKE-TURNKEY

proc DefExc2	b  $	end-code	\ NMI
proc DefExc3	b  $	end-code	\ HardFault
proc DefExc4	b  $	end-code	\ MemManage
proc DefExc5	b  $	end-code	\ BusFault
proc DefExc6	b  $	end-code	\ UsageFault
proc DefExc11	b  $	end-code	\ SVC
proc DefExc12	b  $	end-code	\ DbgMon
proc DefExc14	b  $	end-code	\ PendSV
proc DefExc15	b  $	end-code	\ SysTick

\ Calculate the initial value for the data stack pointer.
\ We allow for TOS being in a register and guard space.

[undefined] sp-guard [if]		\ if no guard value is set
0 equ sp-guard
[then]

init-s0 tos-cached? sp-guard + cells -
  equ real-init-s0	\ -- addr
\ The data stack pointer set at start up.

: StartCortex	\ -- ; never exits
\ *G Set up the Forth registers and start Forth. Other primary
\ ** hardware initialisation can also be performed here.
\ ** All the GPIO blocks are enabled.
  begin
    \ INT_STACK_TOP SP_main sys!		\ set SP_main for interrupts
    \ INIT-R0 SP_process sys!		\ set SP_process for tasks
    \ 2 control sys!			\ switch to SP_process
    \ Don't mess with the stack pointers.  The launcher will handle it.
    REAL-INIT-S0 set-sp			\ Allow for cached TOS and guard space
    INIT-U0 up!				\ USER area
    CLD1 @ execute
  again
;
external

INT_STACK_TOP StackVec# SetExcVec	\ Define initial return stack
' StartCortex ResetVec# SetExcVec	\ Define startup word
DefExc2       2         SetExcVec
DefExc3       3         SetExcVec
DefExc4       4         SetExcVec
DefExc5       5         SetExcVec
DefExc11      11        SetExcVec
DefExc12      12        SetExcVec
DefExc14      14        SetExcVec
DefExc15      15        SetExcVec

\ ------------------------------------------
\ reset values for user and system variables
\ ------------------------------------------

[undefined] umbilical? [if]
L: USER-RESET
  init-s0 tos-cached? sp-guard + cells - ,	\ s0
  init-r0 ,				\ r0
  0 ,  0 ,                              \ #tib, 'tib
  0 ,  0 ,                              \ >in, out
  $0A ,  0 ,                            \ base, hld

\ initial values of system variables
L: INIT-FENCE  0 ,                      \ fence
L: INIT-DP  0 ,                         \ dp
L: INIT-RP  0 ,				\ RP
L: INIT-VOC-LINK  0 ,                   \ voc-link
[then]

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

decimal

\ startSTM32F072.fth - Cortex startup code for SM32F072B-DISCO board
\ Customized for use with SockPuppet.  No hardware init code.

((

To do
=====

Change history
==============
))

only forth definitions  decimal

\ ===========
\ *! startstm32f072
\ *T Cortex start up for STM32F072
\ ===========

l: ExcVecs	\ -- addr ; start of vector table
\ *G The exception vector table is *\fo{/ExcVecs} bytes long. The
\ ** equate is defined in the control file. Note that this table
\ ** table must be correctly aligned as described in the Cortex-M3
\ ** Technical Reference Manual (ARM DDI0337, rev E page 8-21). If
\ ** placed at 0 or the start of Flash, you'll usually be fine.
  /ExcVecs allot&erase

interpreter
: SetExcVec	\ addr exc# --
\ *G Set the given exception vector number to the given address.
\ ** Note that for vectors other than 0, the Thumb bit is forced
\ ** to 1.
  dup if				\ If not the stack top
    swap 1 or swap			\   set the Thumb bit
  endif
  cells ExcVecs + !  ;
target

L: CLD1		\ holds xt of main word
  0 ,					\ fixed by MAKE-TURNKEY

proc DefExc2	b  $	end-code	\ NMI
proc DefExc3	b  $	end-code	\ HardFault
proc DefExc4	b  $	end-code	\ MemManage
proc DefExc5	b  $	end-code	\ BusFault
proc DefExc6	b  $	end-code	\ UsageFault
proc DefExc11	b  $	end-code	\ SVC
proc DefExc12	b  $	end-code	\ DbgMon
proc DefExc14	b  $	end-code	\ PendSV
proc DefExc15	b  $	end-code	\ SysTick

\ Calculate the initial value for the data stack pointer.
\ We allow for TOS being in a register and guard space.

[undefined] sp-guard [if]		\ if no guard value is set
0 equ sp-guard
[then]

init-s0 tos-cached? sp-guard + cells -
  equ real-init-s0	\ -- addr
\ The data stack pointer set at start up.

: StartCortex	\ -- ; never exits
\ *G Set up the Forth registers and start Forth. Other primary
\ ** hardware initialisation can also be performed here.
\ ** All the GPIO blocks are enabled.
  begin
    \ INT_STACK_TOP SP_main sys!		\ set SP_main for interrupts
    INIT-R0 SP_process sys!		\ set SP_process for tasks
    2 control sys!			\ switch to SP_process
    REAL-INIT-S0 set-sp			\ Allow for cached TOS and guard space
    INIT-U0 up!				\ USER area
    CLD1 @ execute
  again
;
external

INT_STACK_TOP StackVec# SetExcVec	\ Define initial return stack
' StartCortex ResetVec# SetExcVec	\ Define startup word
DefExc2       2         SetExcVec
DefExc3       3         SetExcVec
DefExc4       4         SetExcVec
DefExc5       5         SetExcVec
DefExc11      11        SetExcVec
DefExc12      12        SetExcVec
DefExc14      14        SetExcVec
DefExc15      15        SetExcVec

\ ------------------------------------------
\ reset values for user and system variables
\ ------------------------------------------

[undefined] umbilical? [if]
L: USER-RESET
  init-s0 tos-cached? sp-guard + cells - ,	\ s0
  init-r0 ,				\ r0
  0 ,  0 ,                              \ #tib, 'tib
  0 ,  0 ,                              \ >in, out
  $0A ,  0 ,                            \ base, hld

\ initial values of system variables
L: INIT-FENCE  0 ,                      \ fence
L: INIT-DP  0 ,                         \ dp
L: INIT-RP  0 ,				\ RP
L: INIT-VOC-LINK  0 ,                   \ voc-link
[then]

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

decimal


Fix a stack bug in the system call handler.

\ Wrappers for SAPI functions, ABI 2.x

\ Note that the system call number is embedded into the instruction,
\ so this is not so easily parameterized.

#0 equ SAPI_VEC_VERSION
#1 equ SAPI_VEC_01_GetRuntimeLinks
#2 equ SAPI_VEC_02_PutChar
#3 equ SAPI_VEC_03_GetChar
#4 equ SAPI_VEC_04_GetCharAvail
#5 equ SAPI_VEC_05_PutString
#6 equ SAPI_VEC_06_EOL
#14 equ SAPI_VEC_14_PetWatchdog
#15 equ SAPI_VEC_15_GetTimeMS

CODE SAPI-Version  \ -- n
\ *G Get the version of the binary ABI in use.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE GETRUNTIMELINKS  \ type -- n
\ *G Get the runtime linking information.   Type 0 - A Dynamic linking
\ ** table with name, address pairs.  Type 1 - A Zero-Terminated Jump table.
	mov r0, tos
	svc # SAPI_VEC_01_GetRuntimeLinks
	mov tos, r0
	next,
END-CODE

\ --------------------------------------------
\ System calls that will require wrappers
\ --------------------------------------------

CODE (SEREMITFC) \ char base --
\ *G Service call for a single char - This one has a special name because
\ ** It'll be wrapped by something that can respond to the flow control
\ ** return code and PAUSE + Retry
	mov r0, tos
	ldr r1, [ psp ], # 4
	[defined] SAPIWakeSupport? [if] mov r2, up [else] mov r2, # 0 [then]
	svc # SAPI_VEC_02_PutChar
	mov tos, r0
    next,
END-CODE

CODE (SERKEYFC) \ base -- char
\ *G Get a character from the port, or -1 for fail
	mov r0, tos
	[defined] SAPIWakeSupport? [if] mov r1, up [else] mov r1, # 0 [then]
	svc # SAPI_VEC_03_GetChar
	mov tos, r0
	next,
END-CODE

CODE (SERTYPEFC) \ caddr len base -- return
\ *G Output characters.
	mov r0, tos
	ldr r1, [ psp ], # 4
	ldr r2, [ psp ], # 4
	[defined] SAPIWakeSupport? [if] mov r3, up [else] mov r3, # 0 [then]
	svc # SAPI_VEC_05_PutString
	mov tos, r0
	next,
END-CODE

CODE (SERCRFC) \ base -- return
\ *G Send a line terminator to the port.  Return 0 for success, -1 for fail.
	mov r0, tos
	[defined] SAPIWakeSupport? [if] mov r1, up [else] mov r1, # 0 [then]
	svc # SAPI_VEC_06_EOL
	mov tos, r0
	next,
END-CODE

\ --------------------------------------------
\ Direct substitures for existing stuff.
\ --------------------------------------------

CODE (SERKEY?) \ base -- t/f
\ *G Return true if the given stream has a character avilable to read.
\ The call returns the number of chars available.
	mov r0, tos
	svc # SAPI_VEC_04_GetCharAvail
	mov tos, r0
	next,
END-CODE

CODE PETWATCHDOG  \ n --
\ *G Refresh the watchdog.  Pass in a platform-specific number
\ ** To specify a timerout (if supported), or zero for the default value.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_14_PetWatchdog
	ldr tos, [ psp ], # 4
	next,
END-CODE

CODE TICKS  \ -- n
\ *G The current value of the millisecond ticker.
    mov r0, # 0 \ We want the actual value.
	svc # SAPI_VEC_15_GetTimeMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ Wrappers for SAPI functions, ABI 2.x

\ Note that the system call number is embedded into the instruction,
\ so this is not so easily parameterized.

#0 equ SAPI_VEC_VERSION
#1 equ SAPI_VEC_01_GetRuntimeLinks
#2 equ SAPI_VEC_02_PutChar
#3 equ SAPI_VEC_03_GetChar
#4 equ SAPI_VEC_04_GetCharAvail
#5 equ SAPI_VEC_05_PutString
#6 equ SAPI_VEC_06_EOL
#14 equ SAPI_VEC_14_PetWatchdog
#15 equ SAPI_VEC_15_GetTimeMS

CODE SAPI-Version  \ -- n
\ *G Get the version of the binary ABI in use.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

CODE GETRUNTIMELINKS  \ type -- n
\ *G Get the runtime linking information.   Type 0 - A Dynamic linking
\ ** table with name, address pairs.  Type 1 - A Zero-Terminated Jump table.
	mov r0, tos
	svc # SAPI_VEC_01_GetRuntimeLinks
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ --------------------------------------------
\ System calls that will require wrappers
\ --------------------------------------------

CODE (SEREMITFC) \ char base --
\ *G Service call for a single char - This one has a special name because
\ ** It'll be wrapped by something that can respond to the flow control
\ ** return code and PAUSE + Retry
	mov r0, tos
	ldr r1, [ psp ], # 4
	[defined] SAPIWakeSupport? [if] mov r2, up [else] mov r2, # 0 [then]
	svc # SAPI_VEC_02_PutChar
	mov tos, r0
    next,
END-CODE

CODE (SERKEYFC) \ base -- char
\ *G Get a character from the port, or -1 for fail
	mov r0, tos
	[defined] SAPIWakeSupport? [if] mov r1, up [else] mov r1, # 0 [then]
	svc # SAPI_VEC_03_GetChar
	mov tos, r0
	next,
END-CODE

CODE (SERTYPEFC) \ caddr len base -- return
\ *G Output characters.
	mov r0, tos
	ldr r1, [ psp ], # 4
	ldr r2, [ psp ], # 4
	[defined] SAPIWakeSupport? [if] mov r3, up [else] mov r3, # 0 [then]
	svc # SAPI_VEC_05_PutString
	mov tos, r0
	next,
END-CODE

CODE (SERCRFC) \ base -- return
\ *G Send a line terminator to the port.  Return 0 for success, -1 for fail.
	mov r0, tos
	[defined] SAPIWakeSupport? [if] mov r1, up [else] mov r1, # 0 [then]
	svc # SAPI_VEC_06_EOL
	mov tos, r0
	next,
END-CODE

\ --------------------------------------------
\ Direct substitures for existing stuff.
\ --------------------------------------------

CODE (SERKEY?) \ base -- t/f
\ *G Return true if the given stream has a character avilable to read.
\ The call returns the number of chars available.
	mov r0, tos
	svc # SAPI_VEC_04_GetCharAvail
	mov tos, r0
	next,
END-CODE

CODE PETWATCHDOG  \ n --
\ *G Refresh the watchdog.  Pass in a platform-specific number
\ ** To specify a timerout (if supported), or zero for the default value.
	mov r0, tos
	ldr r1, [ psp ], # 4
	svc # SAPI_VEC_14_PetWatchdog
	ldr tos, [ psp ], # 4
	next,
END-CODE

CODE TICKS  \ -- n
\ *G The current value of the millisecond ticker.
    mov r0, # 0 \ We want the actual value.
	svc # SAPI_VEC_15_GetTimeMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE


cleanup example

cleanup example

( LED flashing example
  Hardware: Launchpad

  vi:ft=forth
)

INCLUDE msp430.forth
INCLUDE core.forth

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

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

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

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

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

: SHORT-DELAY 0x4fff DELAY ;
: LONG-DELAY 0xffff DELAY ;
: VERY-LONG-DELAY LONG-DELAY LONG-DELAY ;

: INIT
    [ BIT0 BIT6 + ] LITERAL P1DIR C!
    0 P1OUT C!
    GREEN_ON
    VERY-LONG-DELAY
    GREEN_OFF
    VERY-LONG-DELAY
    VERY-LONG-DELAY
;

: MAIN
    BEGIN
        ( Red flashing )
        RED_ON
        LONG-DELAY
        RED_OFF
        LONG-DELAY

        ( Green flashing if button is pressed )
        S2 IF
            GREEN_ON
            SHORT-DELAY
            GREEN_OFF
            SHORT-DELAY
        ENDIF
    AGAIN
;

( ========================================================================= )
( 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-VARIABLES
CROSS-COMPILE INIT
CROSS-COMPILE MAIN
CROSS-COMPILE-MISSING

( LED flashing example
  Hardware: Launchpad

  vi:ft=forth
)

INCLUDE msp430.forth
INCLUDE core.forth

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

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

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

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

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

: INIT
    [ BIT0 BIT6 + ] LITERAL P1DIR C!
    0 P1OUT C!
    GREEN_ON
    0xffff DELAY 0xffff DELAY
    GREEN_OFF
    0xffff DELAY 0xffff DELAY
    0xffff DELAY 0xffff DELAY
(    10 12 >
    IF 10 ELSE 20 ENDIF
    DROP
)
;

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

( ========================================================================= )
( 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-VARIABLES
CROSS-COMPILE INIT
CROSS-COMPILE MAIN
CROSS-COMPILE-MISSING