Basic tools for calibration.

Basic tools for calibration.

(( 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 ( -- )
  nvramvalid? if _nvramload then
  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? ( -- 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! ( addr -- )
\ *G Save the contents of the needle cal values.
 0 UDPAGE_ERASE
 ( addr )
 $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 !
  odn_ui nvram! 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 ;
: 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@ ;


Add optional support for default override of standard setup; but only if corresponding functions are provided. If override function does not exist, boot remains unmodified. This patch should not result in any changes.

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ Copyright (c) 2006-2013 Devin Teske <dteske@FreeBSD.org>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

marker task-beastie.4th

include /boot/delay.4th

variable logoX
variable logoY

\ Initialize logo placement to defaults
46 logoX !
4  logoY !

: beastie-logo ( x y -- ) \ color BSD mascot (19 rows x 34 columns)

2dup at-xy ."               ,        ," 1+
2dup at-xy ."              /(        )`" 1+
2dup at-xy ."              \ \___   / |" 1+
2dup at-xy ."              /- _  `-/  '" 1+
2dup at-xy ."             (/\/ \ \   /\" 1+
2dup at-xy ."             / /   | `    \" 1+
2dup at-xy ."             O O   ) /    |" 1+
2dup at-xy ."             `-^--'`<     '" 1+
2dup at-xy ."            (_.)  _  )   /" 1+
2dup at-xy ."             `.___/`    /" 1+
2dup at-xy ."               `-----' /" 1+
2dup at-xy ."  <----.     __ / __   \" 1+
2dup at-xy ."  <----|====O)))==) \) /====|" 1+
2dup at-xy ."  <----'    `--' `.__,' \" 1+
2dup at-xy ."               |        |" 1+
2dup at-xy ."                \       /       /\" 1+
2dup at-xy ."           ______( (_  / \______/" 1+
2dup at-xy ."         ,'  ,-----'   |" 1+
     at-xy ."         `--{__________)"

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: beastiebw-logo ( x y -- ) \ B/W BSD mascot (19 rows x 34 columns)

	2dup at-xy ."               ,        ," 1+
	2dup at-xy ."              /(        )`" 1+
	2dup at-xy ."              \ \___   / |" 1+
	2dup at-xy ."              /- _  `-/  '" 1+
	2dup at-xy ."             (/\/ \ \   /\" 1+
	2dup at-xy ."             / /   | `    \" 1+
	2dup at-xy ."             O O   ) /    |" 1+
	2dup at-xy ."             `-^--'`<     '" 1+
	2dup at-xy ."            (_.)  _  )   /" 1+
	2dup at-xy ."             `.___/`    /" 1+
	2dup at-xy ."               `-----' /" 1+
	2dup at-xy ."  <----.     __ / __   \" 1+
	2dup at-xy ."  <----|====O)))==) \) /====|" 1+
	2dup at-xy ."  <----'    `--' `.__,' \" 1+
	2dup at-xy ."               |        |" 1+
	2dup at-xy ."                \       /       /\" 1+
	2dup at-xy ."           ______( (_  / \______/" 1+
	2dup at-xy ."         ,'  ,-----'   |" 1+
	     at-xy ."         `--{__________)"

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: fbsdbw-logo ( x y -- ) \ "FreeBSD" logo in B/W (13 rows x 21 columns)

	\ We used to use the beastie himself as our default... until the
	\ eventual complaint derided his reign of the advanced boot-menu.
	\
	\ This is the replacement of beastie to satiate the haters of our
	\ beloved helper-daemon (ready to track down and spear bugs with
	\ his trident and sporty sneakers; see above).
	\
	\ Since we merely just changed the default and not the default-
	\ location, below is an adjustment to the passed-in coordinates,
	\ forever influenced by the proper location of beastie himself
	\ kept as the default loader_logo_x/loader_logo_y values.
	\
	5 + swap 6 + swap

	2dup at-xy ."  ______" 1+
	2dup at-xy ." |  ____| __ ___  ___ " 1+
	2dup at-xy ." | |__ | '__/ _ \/ _ \" 1+
	2dup at-xy ." |  __|| | |  __/  __/" 1+
	2dup at-xy ." | |   | | |    |    |" 1+
	2dup at-xy ." |_|   |_|  \___|\___|" 1+
	2dup at-xy ."  ____   _____ _____" 1+
	2dup at-xy ." |  _ \ / ____|  __ \" 1+
	2dup at-xy ." | |_) | (___ | |  | |" 1+
	2dup at-xy ." |  _ < \___ \| |  | |" 1+
	2dup at-xy ." | |_) |____) | |__| |" 1+
	2dup at-xy ." |     |      |      |" 1+
	     at-xy ." |____/|_____/|_____/"

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: orb-logo ( x y -- ) \ color Orb mascot (15 rows x 30 columns)

	3 + \ beastie adjustment (see `fbsdbw-logo' comments above)

	2dup at-xy ."  ```                        `" 1+
	2dup at-xy ." s` `.....---.......--.```   -/" 1+
	2dup at-xy ." +o   .--`         /y:`      +." 1+
	2dup at-xy ."  yo`:.            :o      `+-" 1+
	2dup at-xy ."   y/               -/`   -o/" 1+
	2dup at-xy ."  .-                  ::/sy+:." 1+
	2dup at-xy ."  /                     `--  /" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ."  /                          /" 1+
	2dup at-xy ."  .-                        -." 1+
	2dup at-xy ."   --                      -." 1+
	2dup at-xy ."    `:`                  `:`" 1+
	2dup at-xy ."      .--             `--." 1+
	     at-xy ."         .---.....----."

 	\ Put the cursor back at the bottom
 	0 25 at-xy
;

: orbbw-logo ( x y -- ) \ B/W Orb mascot (15 rows x 32 columns)

	3 + \ beastie adjustment (see `fbsdbw-logo' comments above)

	2dup at-xy ."  ```                        `" 1+
	2dup at-xy ." s` `.....---.......--.```   -/" 1+
	2dup at-xy ." +o   .--`         /y:`      +." 1+
	2dup at-xy ."  yo`:.            :o      `+-" 1+
	2dup at-xy ."   y/               -/`   -o/" 1+
	2dup at-xy ."  .-                  ::/sy+:." 1+
	2dup at-xy ."  /                     `--  /" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ."  /                          /" 1+
	2dup at-xy ."  .-                        -." 1+
	2dup at-xy ."   --                      -." 1+
	2dup at-xy ."    `:`                  `:`" 1+
	2dup at-xy ."      .--             `--." 1+
	     at-xy ."         .---.....----."

 	\ Put the cursor back at the bottom
 	0 25 at-xy
;

\ This function draws any number of beastie logos at (loader_logo_x,
\ loader_logo_y) if defined, else (46,4) (to the right of the menu). To choose
\ your beastie, set the variable `loader_logo' to the respective logo name.
\
\ Currently available:
\
\ 	NAME        DESCRIPTION
\ 	beastie     Color ``Helper Daemon'' mascot (19 rows x 34 columns)
\ 	beastiebw   B/W ``Helper Daemon'' mascot (19 rows x 34 columns)
\ 	fbsdbw      "FreeBSD" logo in B/W (13 rows x 21 columns)
\ 	orb         Color ``Orb'' mascot (15 rows x 30 columns) (2nd default)
\ 	orbbw       B/W ``Orb'' mascot (15 rows x 32 columns)
\ 	tribute     Color ``Tribute'' (must fit 19 rows x 34 columns) (default)
\ 	tributebw   B/W ``Tribute'' (must fit 19 rows x 34 columns)
\
\ NOTE: Setting `loader_logo' to an undefined value (such as "none") will
\       prevent beastie from being drawn.
\
: draw-beastie ( -- ) \ at (loader_logo_x,loader_logo_y), else (46,4)

	s" loader_logo_x" getenv dup -1 <> if
		?number 1 = if logoX ! then
	else
		drop
	then
	s" loader_logo_y" getenv dup -1 <> if
		?number 1 = if logoY ! then
	else
		drop
	then

	s" loader_logo" getenv dup -1 = if
		logoX @ logoY @
		loader_color? if
			s" tribute-logo"
			sfind if
				execute
			else
				drop
				orb-logo
			then
		else
			s" tributebw-logo"
			sfind if
				execute
			else
				drop
				orbbw-logo
			then
		then
		drop exit
	then

	2dup s" beastie" compare-insensitive 0= if
		logoX @ logoY @ beastie-logo
		2drop exit
	then
	2dup s" beastiebw" compare-insensitive 0= if
		logoX @ logoY @ beastiebw-logo
		2drop exit
	then
	2dup s" fbsdbw" compare-insensitive 0= if
		logoX @ logoY @ fbsdbw-logo
		2drop exit
	then
	2dup s" orb" compare-insensitive 0= if
		logoX @ logoY @ orb-logo
		2drop exit
	then
	2dup s" orbbw" compare-insensitive 0= if
		logoX @ logoY @ orbbw-logo
		2drop exit
	then
	2dup s" tribute" compare-insensitive 0= if
		logoX @ logoY @
		s" tribute-logo" sfind if
			execute
		else
			orb-logo
		then
		2drop exit
	then
	2dup s" tributebw" compare-insensitive 0= if
		logoX @ logoY @
		s" tributebw-logo" sfind if
			execute
		else
			orbbw-logo
		then
		2drop exit
	then

	2drop
;

: clear-beastie ( -- ) \ clears beastie from the screen
	logoX @ logoY @
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces		2drop

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: beastie-start ( -- ) \ starts the menu
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	else
		drop
	then

	s" loader_delay" getenv
	-1 = if
		s" include /boot/menu.rc" evaluate
	else
		drop
		." Loading Menu (Ctrl-C to Abort)" cr
		s" set delay_command='include /boot/menu.rc'" evaluate
		s" set delay_showdots" evaluate
		delay_execute
	then
;

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ Copyright (c) 2006-2013 Devin Teske <dteske@FreeBSD.org>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

marker task-beastie.4th

include /boot/delay.4th

variable logoX
variable logoY

\ Initialize logo placement to defaults
46 logoX !
4  logoY !

: beastie-logo ( x y -- ) \ color BSD mascot (19 rows x 34 columns)

2dup at-xy ."               ,        ," 1+
2dup at-xy ."              /(        )`" 1+
2dup at-xy ."              \ \___   / |" 1+
2dup at-xy ."              /- _  `-/  '" 1+
2dup at-xy ."             (/\/ \ \   /\" 1+
2dup at-xy ."             / /   | `    \" 1+
2dup at-xy ."             O O   ) /    |" 1+
2dup at-xy ."             `-^--'`<     '" 1+
2dup at-xy ."            (_.)  _  )   /" 1+
2dup at-xy ."             `.___/`    /" 1+
2dup at-xy ."               `-----' /" 1+
2dup at-xy ."  <----.     __ / __   \" 1+
2dup at-xy ."  <----|====O)))==) \) /====|" 1+
2dup at-xy ."  <----'    `--' `.__,' \" 1+
2dup at-xy ."               |        |" 1+
2dup at-xy ."                \       /       /\" 1+
2dup at-xy ."           ______( (_  / \______/" 1+
2dup at-xy ."         ,'  ,-----'   |" 1+
     at-xy ."         `--{__________)"

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: beastiebw-logo ( x y -- ) \ B/W BSD mascot (19 rows x 34 columns)

	2dup at-xy ."               ,        ," 1+
	2dup at-xy ."              /(        )`" 1+
	2dup at-xy ."              \ \___   / |" 1+
	2dup at-xy ."              /- _  `-/  '" 1+
	2dup at-xy ."             (/\/ \ \   /\" 1+
	2dup at-xy ."             / /   | `    \" 1+
	2dup at-xy ."             O O   ) /    |" 1+
	2dup at-xy ."             `-^--'`<     '" 1+
	2dup at-xy ."            (_.)  _  )   /" 1+
	2dup at-xy ."             `.___/`    /" 1+
	2dup at-xy ."               `-----' /" 1+
	2dup at-xy ."  <----.     __ / __   \" 1+
	2dup at-xy ."  <----|====O)))==) \) /====|" 1+
	2dup at-xy ."  <----'    `--' `.__,' \" 1+
	2dup at-xy ."               |        |" 1+
	2dup at-xy ."                \       /       /\" 1+
	2dup at-xy ."           ______( (_  / \______/" 1+
	2dup at-xy ."         ,'  ,-----'   |" 1+
	     at-xy ."         `--{__________)"

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: fbsdbw-logo ( x y -- ) \ "FreeBSD" logo in B/W (13 rows x 21 columns)

	\ We used to use the beastie himself as our default... until the
	\ eventual complaint derided his reign of the advanced boot-menu.
	\
	\ This is the replacement of beastie to satiate the haters of our
	\ beloved helper-daemon (ready to track down and spear bugs with
	\ his trident and sporty sneakers; see above).
	\
	\ Since we merely just changed the default and not the default-
	\ location, below is an adjustment to the passed-in coordinates,
	\ forever influenced by the proper location of beastie himself
	\ kept as the default loader_logo_x/loader_logo_y values.
	\
	5 + swap 6 + swap

	2dup at-xy ."  ______" 1+
	2dup at-xy ." |  ____| __ ___  ___ " 1+
	2dup at-xy ." | |__ | '__/ _ \/ _ \" 1+
	2dup at-xy ." |  __|| | |  __/  __/" 1+
	2dup at-xy ." | |   | | |    |    |" 1+
	2dup at-xy ." |_|   |_|  \___|\___|" 1+
	2dup at-xy ."  ____   _____ _____" 1+
	2dup at-xy ." |  _ \ / ____|  __ \" 1+
	2dup at-xy ." | |_) | (___ | |  | |" 1+
	2dup at-xy ." |  _ < \___ \| |  | |" 1+
	2dup at-xy ." | |_) |____) | |__| |" 1+
	2dup at-xy ." |     |      |      |" 1+
	     at-xy ." |____/|_____/|_____/"

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: orb-logo ( x y -- ) \ color Orb mascot (15 rows x 30 columns)

	3 + \ beastie adjustment (see `fbsdbw-logo' comments above)

	2dup at-xy ."  ```                        `" 1+
	2dup at-xy ." s` `.....---.......--.```   -/" 1+
	2dup at-xy ." +o   .--`         /y:`      +." 1+
	2dup at-xy ."  yo`:.            :o      `+-" 1+
	2dup at-xy ."   y/               -/`   -o/" 1+
	2dup at-xy ."  .-                  ::/sy+:." 1+
	2dup at-xy ."  /                     `--  /" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ."  /                          /" 1+
	2dup at-xy ."  .-                        -." 1+
	2dup at-xy ."   --                      -." 1+
	2dup at-xy ."    `:`                  `:`" 1+
	2dup at-xy ."      .--             `--." 1+
	     at-xy ."         .---.....----."

 	\ Put the cursor back at the bottom
 	0 25 at-xy
;

: orbbw-logo ( x y -- ) \ B/W Orb mascot (15 rows x 32 columns)

	3 + \ beastie adjustment (see `fbsdbw-logo' comments above)

	2dup at-xy ."  ```                        `" 1+
	2dup at-xy ." s` `.....---.......--.```   -/" 1+
	2dup at-xy ." +o   .--`         /y:`      +." 1+
	2dup at-xy ."  yo`:.            :o      `+-" 1+
	2dup at-xy ."   y/               -/`   -o/" 1+
	2dup at-xy ."  .-                  ::/sy+:." 1+
	2dup at-xy ."  /                     `--  /" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ." `:                          :`" 1+
	2dup at-xy ."  /                          /" 1+
	2dup at-xy ."  .-                        -." 1+
	2dup at-xy ."   --                      -." 1+
	2dup at-xy ."    `:`                  `:`" 1+
	2dup at-xy ."      .--             `--." 1+
	     at-xy ."         .---.....----."

 	\ Put the cursor back at the bottom
 	0 25 at-xy
;

\ This function draws any number of beastie logos at (loader_logo_x,
\ loader_logo_y) if defined, else (46,4) (to the right of the menu). To choose
\ your beastie, set the variable `loader_logo' to the respective logo name.
\
\ Currently available:
\
\ 	NAME        DESCRIPTION
\ 	beastie     Color ``Helper Daemon'' mascot (19 rows x 34 columns)
\ 	beastiebw   B/W ``Helper Daemon'' mascot (19 rows x 34 columns)
\ 	fbsdbw      "FreeBSD" logo in B/W (13 rows x 21 columns)
\ 	orb         Color ``Orb'' mascot (15 rows x 30 columns) (default)
\ 	orbbw       B/W ``Orb'' mascot (15 rows x 32 columns)
\
\ NOTE: Setting `loader_logo' to an undefined value (such as "none") will
\       prevent beastie from being drawn.
\
: draw-beastie ( -- ) \ at (loader_logo_x,loader_logo_y), else (46,4)

	s" loader_logo_x" getenv dup -1 <> if
		?number 1 = if logoX ! then
	else
		drop
	then
	s" loader_logo_y" getenv dup -1 <> if
		?number 1 = if logoY ! then
	else
		drop
	then

	s" loader_logo" getenv dup -1 = if
		logoX @ logoY @
		loader_color? if
			orb-logo
		else
			orbbw-logo
		then
		drop exit
	then

	2dup s" beastie" compare-insensitive 0= if
		logoX @ logoY @ beastie-logo
		2drop exit
	then
	2dup s" beastiebw" compare-insensitive 0= if
		logoX @ logoY @ beastiebw-logo
		2drop exit
	then
	2dup s" fbsdbw" compare-insensitive 0= if
		logoX @ logoY @ fbsdbw-logo
		2drop exit
	then
	2dup s" orb" compare-insensitive 0= if
		logoX @ logoY @ orb-logo
		2drop exit
	then
	2dup s" orbbw" compare-insensitive 0= if
		logoX @ logoY @ orbbw-logo
		2drop exit
	then

	2drop
;

: clear-beastie ( -- ) \ clears beastie from the screen
	logoX @ logoY @
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces 1+		2dup at-xy 34 spaces 1+
	2dup at-xy 34 spaces		2drop

	\ Put the cursor back at the bottom
	0 25 at-xy
;

: beastie-start ( -- ) \ starts the menu
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	else
		drop
	then

	s" loader_delay" getenv
	-1 = if
		s" include /boot/menu.rc" evaluate
	else
		drop
		." Loading Menu (Ctrl-C to Abort)" cr
		s" set delay_command='include /boot/menu.rc'" evaluate
		s" set delay_showdots" evaluate
		delay_execute
	then
;


Switch to ints for the On-Deck values.

Switch to ints for the On-Deck values.


Removed the unused core.fth file.

Removed the unused core.fth file.

( block 1  -- Main load block )

VARIABLE STATE  ( compilation state variable )
0 STATE !       ( interpreting by default )

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

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

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

( block 30  CORE words )

1 FH 8 FH THRU
10 FH LOAD          \ compiler
( shadow 30 )
( block 31 stack primitives )

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

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

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

-1 CONSTANT TRUE   0 CONSTANT FALSE

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

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

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

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

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

( shadow 33 )
( block 34  variables )

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

VARIABLE DP
( shadow 34 )
( block 35 math )

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

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

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

( shadow 35 )
( block 36  math continued )

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

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

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

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

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

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

( shadow 37 )
( block 38 memory access )

: +! ( n a-addr -- )  DUP >R @ + R> ! ;
: 2! ( x1 x2 a-addr -- )  SWAP OVER ! CELL+ ! ;
: 2@ ( a-addr -- x1 x2 )  DUP CELL+ @ SWAP @ ;
: COUNT ( c-addr1 -- c-addr2 u )  DUP CHAR+ SWAP C@ ;
( shadow 38 )
( block 39 )
( shadow 39 )
( block 40 compiler )

: [  FALSE STATE ! ; IMMEDIATE
: ]  TRUE STATE ! ;

: ALLOT ( n -- )  DP +! ;
: HERE ( -- a ) DP @ ;
: , ( n -- )  HERE [ 1 CELLS ] LITERAL ALLOT ! ;
: COMPILE, ( xt -- )  HERE [ 1 INSTRS ] LITERAL ALLOT ! ;
: LITERAL ( x -- )  ['] _LIT COMPILE, , ; IMMEDIATE

: VARIABLE CREATE 1 CELLS ALLOT ;
: CONSTANT CREATE , DOES> @ ;

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

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

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

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

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


Re-order things.

Re-order things.

\ Wrappers for SAPI Core functions
\ SVC 0: Return the version of the API in use.
\ SVC 1: Return the address of the shared variables table
\ SVC 2: putchar
\ SVC 3: getchar
\ SVC 4: charsavail

\ SVC 5: Reserved
\ SVC 6: Reserved
\ SVC 7: Reserved

\ SVC 8: Watchdog Refresh
\ SVC 9: Return Millisecond ticker value.
\ SVC 10: The number of CPU cycles consumed in the last second.

\ 2-4 are for use by the serial io routines, and are
\ defined elsewhere.

\ 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_VARS
#2 equ SAPI_VEC_PUTCHAR
#3 equ SAPI_VEC_GETCHAR
#4 equ SAPI_VEC_CHARSAVAIL

#8 equ SAPI_VEC_PETWATCHDOG
#9 equ SAPI_VEC_USAGE
#10 equ SAPI_VEC_GETMS

\ **********************************************************************
\ SVC 0: Return the version of the API in use.
\ **********************************************************************
CODE SAPI-Version  \ -- n
	\ Push TOS, and place the result there.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ **********************************************************************
\ SVC 1: Get the address of the shared variable list
\ **********************************************************************
CODE GetSharedVars  \ -- n
	svc # SAPI_VEC_VARS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ **********************************************************************
\ SVC 8: Refresh the watchdog
\ **********************************************************************
CODE PetWatchDog  \ --
	svc # SAPI_VEC_PETWATCHDOG
	next,
END-CODE

\ **********************************************************************
\ SVC 9: Return Millisecond ticker value.
\ **********************************************************************
CODE Ticks  \ -- n
	svc # SAPI_VEC_GETMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ **********************************************************************
\ SVC 10: The number of CPU cycles consumed in the last second.
\ **********************************************************************
CODE GetUsage  \ -- n
	svc # SAPI_VEC_USAGE
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ Wrappers for SAPI Core functions
\ SVC 0: Return the version of the API in use.
\ SVC 1: Return the address of the shared variables table
\ SVC 2: putchar
\ SVC 3: getchar
\ SVC 4: charsavail

\ SVC 5: Reserved
\ SVC 6: Reserved
\ SVC 7: Reserved

\ SVC 8: Watchdog Refresh
\ SVC 9: Return Millisecond ticker value.
\ SVC 10: The number of CPU cycles consumed in the last second.

\ 2-4 are for use by the serial io routines, and are
\ defined elsewhere.

\ 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_PUTCHAR
#2 equ SAPI_VEC_GETCHAR
#3 equ SAPI_VEC_CHARSAVAIL

#8 equ SAPI_VEC_VARS
#9 equ SAPI_VEC_USAGE
#10 equ SAPI_VEC_GETMS

\ **********************************************************************
\ SVC 0: Return the version of the API in use.
\ **********************************************************************
CODE SAPI-Version  \ -- n
	\ Push TOS, and place the result there.
	svc # SAPI_VEC_VERSION
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ **********************************************************************
\ SVC 1: Get the address of the shared variable list
\ **********************************************************************
CODE GetSharedVars  \ -- n
	svc # SAPI_VEC_VARS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ **********************************************************************
\ SVC 9: Return Millisecond ticker value.
\ **********************************************************************
CODE Ticks  \ -- n
	svc # SAPI_VEC_GETMS
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE

\ **********************************************************************
\ SVC 10: The number of CPU cycles consumed in the last second.
\ **********************************************************************
CODE GetUsage  \ -- n
	svc # SAPI_VEC_USAGE
	str tos, [ psp, # -4 ] !
	mov tos, r0
	next,
END-CODE


update vector to use shorthand props

update vector to use shorthand props

package Math
class Vector
#< Represents a [vector](https://en.wikipedia.org/wiki/Vector_space) of any
#| dimension.

$docOption_instanceName = "v"

#> Creates a vector with the given components.
init {
    want @items: Num...
    if @dimension < 1
        throw Error(:DimensionError, "Need dimension >= 1D")
}

#> dimension of the vector
.dimension -> @items.length

#> human-readable dimension of the vector
.dimensionHR -> @dimension + "D"

#> magnitude of the vector
.magnitude -> @items.map! { -> $_ ^ 2 }.sum.sqrt

#> unit vector in the direction of this vector
.unitVector -> *self / @magnitude

#> returns the unit vector in the direction of the given axis
method axisUnitVector {
    need $axis: VectorAxis #< axis number or letter, starting at 1 or "i"
    return Vector.axisUnitVector(@dimension, $axis)
}

.x -> *self[0]  #< for a >=1D vector, the first comonent
.y -> *self[1]  #< for a >=2D vector, the second component
.z -> *self[2]  #< for a >=3D vector, the third component

#> for a 2D vector, its direction, measured in radians
.direction {
    if @dimension != 2
        throw Error(:DimensionError, "Direction only exists in 2D")
    return Math.atan2(@y, @x)
}

#> addition of two vectors
operator + {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $ehs.dimensionHR != @dimensionHR")
    $items = gather for $i in 0..@items.lastIndex {
        take *self[$i] + $ehs[$i]
    }
    return Vector(items: $items)
}

#> allows you to take the opposite vector `-$u`
operator - {
    need $lhs: Num
    if $lhs != 0
        throw(:InvalidOperation, "Unsupported operation")
    return Vector(items: gather for $x in @items {
        take -$x
    })
}

#> subtraction of a vector from another
operator - {
    need $rhs: Vector
    if $rhs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $rhs.dimensionHR != @dimensionHR")
    $items = gather for $i in 0..@items.lastIndex {
        take *self[$i] - $rhs[$i]
    }
    return Vector(items: $items)
}

#> scalar multiplication of the vector
operator * {
    need $ehs: Num
    return Vector(items: @items.map! { -> $_ * $ehs })
}

#> scalar division of the vector
operator / {
    need $rhs: Num
    return *self * (1 / $rhs)
}

#> dot product of two vectors
operator * {
    need $ehs: Vector
    return @dot($ehs)
}

#> vector equality
operator == {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        return false
    for $i in 0..@items.lastIndex {
        if *self[$i] == $ehs[$i]
            next
        return false
    }
    return true
}

#> dot product of this vector and another of the same dimension
method dot {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $ehs.dimensionHR != @dimensionHR")
    $dot = 0
    for $i in 0..@items.lastIndex {
        $dot += *self[$i] * $ehs[$i]
    }
    return $dot
}

#> cross product of two 3D vectors
method cross {
    need $ehs: Vector
    if $ehs.dimension != 3 || @dimension != 3
        throw Error(:DimensionError, "Cross product only exists in 3D")
    @a = *self[1] * $ehs[2] - *self[2] * $ehs[1]
    @b = *self[2] * $ehs[0] - *self[0] * $ehs[2]
    @c = *self[0] * $ehs[1] - *self[1] * $ehs[0]
    return Vector(@a, @b, @c)
}

#> angle between this vector and another of the same dimension, measured in
#| radians
method angleBetween {
    need $ehs: Vector
    # a·b = |a||b|cosθ
    $cosθ = @dot($ehs) / (@magnitude * $ehs.magnitude)
    return Math.acos($cosθ)
}

#> true if this vector is orthogonal to another of the same dimension
# consider: the dot product is also zero if either is a zero vector. should
# we still return true in that case?
method orthogonalTo {
    need $ehs: Vector
    return @dot($ehs) == 0
}

#> true if this vector is parallel to another of the same dimension
method parallelTo {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $ehs.dimensionHR != @dimensionHR")
    $u1 = @unitVector
    $u2 = $ehs.unitVector
    if $u1 == $u2 || -$u1 == $u2
        return true
    return false
}

#> fetches the component at the given index. Allows Vector to conform to
#| IndexedRead such that `$vector[N]` is the N+1th component.
method getValue {
    need $index: Num
    $n = $index + 1
    if @dimension < $n
        throw Error(:DimensionError, "@dimensionHR vector has no component $n")
    return @items[$index]
}

#> returns a copy of the vector
method copy {
    return Vector(items: @items.copy!)
}

method description {
    return "<" + @items.join(", ") + ">"
}

#> returns the zero vector in the given dimension
func zeroVector {
    need $dimension: Num
    if $dimension < 1
        throw Error(:DimensionError, "Need dimension >= 1D")
    return Vector(items: gather for $i in 1..$dimension { take 0 })
}

#> returns the unit vector for the given dimension and axis
func axisUnitVector {
    need $dimension: Num
    need $axis: VectorAxis #< axis number or letter, starting at 1 or "i"
    if $dimension < 1
        throw Error(:DimensionError, "Need dimension >= 1D")
    $items = gather for $i in 1..$dimension {
        if $i == $axis {
            take 1
            next
        }
        take 0
    }
    return Vector(items: $items)
}

func _axisToNumber {
    need $axis: Num | Char
    if $axis.*isa(Num)
        return $axis
    $o = $axis.ord
    if $o > 119
        return $o - 119
    return $o - 104
}

#> An interface which accepts an axis letter starting at "i" or number starting
#| at 1. For instance, a 3D vector is represented by axes i, j, and k, which
#| correspond to the numbers 1, 2, and 3, respectively.
type VectorAxis {
    #> converts letters starting at 'i' to axis numbers
    transform _axisToNumber($_)
}

package Math
class Vector
#< Represents a [vector](https://en.wikipedia.org/wiki/Vector_space) of any
#| dimension.

$docOption_instanceName = "v"

#> Creates a vector with the given components.
init {
    want @items: Num...
    if @dimension < 1
        throw Error(:DimensionError, "Need dimension >= 1D")
}

#> dimension of the vector
prop dimension {
    return @items.length
}

#> human-readable dimension of the vector
prop dimensionHR {
    return @dimension + "D"
}

#> magnitude of the vector
prop magnitude {
    return @items.map! { -> $_ ^ 2 }.sum.sqrt
}

#> unit vector in the direction of this vector
prop unitVector {
    return *self / @magnitude
}

#> returns the unit vector in the direction of the given axis
method axisUnitVector {
    need $axis: VectorAxis #< axis number or letter, starting at 1 or "i"
    return Vector.axisUnitVector(@dimension, $axis)
}

#> for a >=1D vector, the first comonent
prop x {
    return *self[0]
}

#> for a >=2D vector, the second component
prop y {
    return *self[1]
}

#> for a >=3D vector, the third component
prop z {
    return *self[2]
}

#> for a 2D vector, its direction, measured in radians
prop direction {
    if @dimension != 2
        throw Error(:DimensionError, "Direction only exists in 2D")
    return Math.atan2(@y, @x)
}

#> addition of two vectors
operator + {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $ehs.dimensionHR != @dimensionHR")
    $items = gather for $i in 0..@items.lastIndex {
        take *self[$i] + $ehs[$i]
    }
    return Vector(items: $items)
}

#> allows you to take the opposite vector `-$u`
operator - {
    need $lhs: Num
    if $lhs != 0
        throw(:InvalidOperation, "Unsupported operation")
    return Vector(items: gather for $x in @items {
        take -$x
    })
}

#> subtraction of a vector from another
operator - {
    need $rhs: Vector
    if $rhs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $rhs.dimensionHR != @dimensionHR")
    $items = gather for $i in 0..@items.lastIndex {
        take *self[$i] - $rhs[$i]
    }
    return Vector(items: $items)
}

#> scalar multiplication of the vector
operator * {
    need $ehs: Num
    return Vector(items: @items.map! { -> $_ * $ehs })
}

#> scalar division of the vector
operator / {
    need $rhs: Num
    return *self * (1 / $rhs)
}

#> dot product of two vectors
operator * {
    need $ehs: Vector
    return @dot($ehs)
}

#> vector equality
operator == {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        return false
    for $i in 0..@items.lastIndex {
        if *self[$i] == $ehs[$i]
            next
        return false
    }
    return true
}

#> dot product of this vector and another of the same dimension
method dot {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $ehs.dimensionHR != @dimensionHR")
    $dot = 0
    for $i in 0..@items.lastIndex {
        $dot += *self[$i] * $ehs[$i]
    }
    return $dot
}

#> cross product of two 3D vectors
method cross {
    need $ehs: Vector
    if $ehs.dimension != 3 || @dimension != 3
        throw Error(:DimensionError, "Cross product only exists in 3D")
    @a = *self[1] * $ehs[2] - *self[2] * $ehs[1]
    @b = *self[2] * $ehs[0] - *self[0] * $ehs[2]
    @c = *self[0] * $ehs[1] - *self[1] * $ehs[0]
    return Vector(@a, @b, @c)
}

#> angle between this vector and another of the same dimension, measured in
#| radians
method angleBetween {
    need $ehs: Vector
    # a·b = |a||b|cosθ
    $cosθ = @dot($ehs) / (@magnitude * $ehs.magnitude)
    return Math.acos($cosθ)
}

#> true if this vector is orthogonal to another of the same dimension
# consider: the dot product is also zero if either is a zero vector. should
# we still return true in that case?
method orthogonalTo {
    need $ehs: Vector
    return @dot($ehs) == 0
}

#> true if this vector is parallel to another of the same dimension
method parallelTo {
    need $ehs: Vector
    if $ehs.dimension != @dimension
        throw Error(:DimensionError, "Dimension mismatch $ehs.dimensionHR != @dimensionHR")
    $u1 = @unitVector
    $u2 = $ehs.unitVector
    if $u1 == $u2 || -$u1 == $u2
        return true
    return false
}

#> fetches the component at the given index. Allows Vector to conform to
#| IndexedRead such that `$vector[N]` is the N+1th component.
method getValue {
    need $index: Num
    $n = $index + 1
    if @dimension < $n
        throw Error(:DimensionError, "@dimensionHR vector has no component $n")
    return @items[$index]
}

#> returns a copy of the vector
method copy {
    return Vector(items: @items.copy!)
}

method description {
    return "<" + @items.join(", ") + ">"
}

#> returns the zero vector in the given dimension
func zeroVector {
    need $dimension: Num
    if $dimension < 1
        throw Error(:DimensionError, "Need dimension >= 1D")
    return Vector(items: gather for $i in 1..$dimension { take 0 })
}

#> returns the unit vector for the given dimension and axis
func axisUnitVector {
    need $dimension: Num
    need $axis: VectorAxis #< axis number or letter, starting at 1 or "i"
    if $dimension < 1
        throw Error(:DimensionError, "Need dimension >= 1D")
    $items = gather for $i in 1..$dimension {
        if $i == $axis {
            take 1
            next
        }
        take 0
    }
    return Vector(items: $items)
}

func _axisToNumber {
    need $axis: Num | Char
    if $axis.*isa(Num)
        return $axis
    $o = $axis.ord
    if $o > 119
        return $o - 119
    return $o - 104
}

#> An interface which accepts an axis letter starting at "i" or number starting
#| at 1. For instance, a 3D vector is represented by axes i, j, and k, which
#| correspond to the numbers 1, 2, and 3, respectively.
type VectorAxis {
    #> converts letters starting at 'i' to axis numbers
    transform _axisToNumber($_)
}


Put some version checking.

Put some version checking.

\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

s" arch-alpha" environment? [if]
s" loader_version" environment? 3 < abort" Loader version 0.3+ required"
[then]

s" arch-i386" environment? [if]
s" loader_version" environment? 8 < abort" Loader version 0.8+ required"
[then]

include /boot/support.4th

only forth definitions also support-functions

\ ***** boot-conf
\
\	Prepares to boot as specified by loaded configuration files.

also support-functions definitions

: bootpath s" /boot/" ;
: modulepath s" module_path" ;
: saveenv ( addr len | 0 -1 -- addr' len | 0 -1 )
  dup -1 = if exit then
  dup allocate abort" Out of memory"
  swap 2dup 2>r
  move
  2r>
;
: freeenv ( addr len | 0 -1 )
  -1 = if drop else free abort" Freeing error" then
;
: restoreenv  ( addr len | 0 -1 -- )
  dup -1 = if ( it wasn't set )
    2drop
    modulepath unsetenv
  else
    over >r
    modulepath setenv
    r> free abort" Freeing error"
  then
;

only forth also support-functions also builtins definitions

: boot-conf  ( args 1 | 0 "args" -- flag )
  0 1 unload drop

  0= if ( interpreted )
    \ Get next word on the command line
    bl word count
    ?dup 0= if ( there wasn't anything )
      drop 0
    else ( put in the number of strings )
      1
    then
  then ( interpreted )

  if ( there are arguments )
    \ Try to load the kernel
    s" kernel_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then

    1 load if ( load command failed )
      \ Remove garbage from the stack

      \ Set the environment variable module_path, and try loading
      \ the kernel again.

      \ First, save module_path value
      modulepath getenv saveenv dup -1 = if 0 swap then 2>r

      \ Sets the new value
      2dup modulepath setenv

      \ Try to load the kernel
      s" load ${kernel} ${kernel_options}" ['] evaluate catch
      if ( load failed yet again )
	\ Remove garbage from the stack
	2drop

	\ Try prepending /boot/
	bootpath 2over nip over + allocate
	if ( out of memory )
	  2drop 2drop
	  2r> restoreenv
	  100 exit
	then

	0 2swap strcat 2swap strcat
	2dup modulepath setenv

	drop free if ( freeing memory error )
	  2drop
	  2r> restoreenv
	  100 exit
	then

	\ Now, once more, try to load the kernel
	s" load ${kernel} ${kernel_options}" ['] evaluate catch
	if ( failed once more )
	  2drop
	  2r> restoreenv
	  100 exit
	then

      else ( we found the kernel on the path passed )

	2drop ( discard command line arguments )

      then ( could not load kernel from directory passed )

      \ Load the remaining modules, if the kernel was loaded at all
      ['] load_modules catch if 2r> restoreenv 100 exit then

      \ Call autoboot to perform the booting
      0 1 autoboot

      \ Keep new module_path
      2r> freeenv

      exit
    then ( could not load kernel with name passed )

    2drop ( discard command line arguments )

  else ( try just a straight-forward kernel load )
    s" load ${kernel} ${kernel_options}" ['] evaluate catch
    if ( kernel load failed ) 2drop 100 exit then

  then ( there are command line arguments )

  \ Load the remaining modules, if the kernel was loaded at all
  ['] load_modules catch if 100 exit then

  \ Call autoboot to perform the booting
  0 1 autoboot
;

also forth definitions
builtin: boot-conf
only forth definitions also support-functions

\ ***** check-password
\
\	If a password was defined, execute autoboot and ask for
\	password if autoboot returns.

: check-password
  password .addr @ if
    0 autoboot
    false >r
    begin
      bell emit bell emit
      ." Password: "
      password .len @ read-password
      dup password .len @ = if
        2dup password .addr @ password .len @
        compare 0= if r> drop true >r then
      then
      drop free drop
      r@
    until
    r> drop
  then
;

\ ***** start
\
\       Initializes support.4th global variables, sets loader_conf_files,
\       process conf files, and, if any one such file was succesfully
\       read to the end, load kernel and modules.

: start  ( -- ) ( throws: abort & user-defined )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  \ Will *NOT* try to load kernel and modules if no configuration file
  \ was succesfully loaded!
  any_conf_read? if
    load_kernel
    load_modules
  then
;

\ ***** initialize
\
\	Overrides support.4th initialization word with one that does
\	everything start one does, short of loading the kernel and
\	modules. Returns a flag

: initialize ( -- flag )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  any_conf_read?
;

\ ***** read-conf
\
\	Read a configuration file, whose name was specified on the command
\	line, if interpreted, or given on the stack, if compiled in.

: (read-conf)  ( addr len -- )
  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
  strdup conf_files .len ! conf_files .addr !
  include_conf_files \ Will recurse on new loader_conf_files definitions
;

: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
  state @ if
    \ Compiling
    postpone (read-conf)
  else
    \ Interpreting
    bl parse (read-conf)
  then
; immediate

\ ***** enable-module
\
\       Turn a module loading on.

: enable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      true r> module.flag !
      ."  will be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** disable-module
\
\       Turn a module loading off.

: disable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      false r> module.flag !
      ."  will not be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** toggle-module
\
\       Turn a module loading on/off.

: toggle-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      r@ module.flag @ 0= dup r> module.flag !
      if
        ."  will be loaded." cr
      else
        ."  will not be loaded." cr
      then
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** show-module
\
\	Show loading information about a module.

: show-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ Words to be used inside configuration files

: retry false ;         \ For use in load error commands
: ignore true ;         \ For use in load error commands

\ Return to strict forth vocabulary

only forth also

\ Copyright (c) 1999 Daniel C. Sobral <dcs@freebsd.org>
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions
\ are met:
\ 1. Redistributions of source code must retain the above copyright
\    notice, this list of conditions and the following disclaimer.
\ 2. Redistributions in binary form must reproduce the above copyright
\    notice, this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
\ SUCH DAMAGE.
\
\ $FreeBSD$

include /boot/support.4th

only forth definitions also support-functions

\ ***** boot-conf
\
\	Prepares to boot as specified by loaded configuration files.

also support-functions definitions

: bootpath s" /boot/" ;
: modulepath s" module_path" ;
: saveenv ( addr len | 0 -1 -- addr' len | 0 -1 )
  dup -1 = if exit then
  dup allocate abort" Out of memory"
  swap 2dup 2>r
  move
  2r>
;
: freeenv ( addr len | 0 -1 )
  -1 = if drop else free abort" Freeing error" then
;
: restoreenv  ( addr len | 0 -1 -- )
  dup -1 = if ( it wasn't set )
    2drop
    modulepath unsetenv
  else
    over >r
    modulepath setenv
    r> free abort" Freeing error"
  then
;

only forth also support-functions also builtins definitions

: boot-conf  ( args 1 | 0 "args" -- flag )
  0 1 unload drop

  0= if ( interpreted )
    \ Get next word on the command line
    bl word count
    ?dup 0= if ( there wasn't anything )
      drop 0
    else ( put in the number of strings )
      1
    then
  then ( interpreted )

  if ( there are arguments )
    \ Try to load the kernel
    s" kernel_options" getenv dup -1 = if drop 2dup 1 else 2over 2 then

    1 load if ( load command failed )
      \ Remove garbage from the stack

      \ Set the environment variable module_path, and try loading
      \ the kernel again.

      \ First, save module_path value
      modulepath getenv saveenv dup -1 = if 0 swap then 2>r

      \ Sets the new value
      2dup modulepath setenv

      \ Try to load the kernel
      s" load ${kernel} ${kernel_options}" ['] evaluate catch
      if ( load failed yet again )
	\ Remove garbage from the stack
	2drop

	\ Try prepending /boot/
	bootpath 2over nip over + allocate
	if ( out of memory )
	  2drop 2drop
	  2r> restoreenv
	  100 exit
	then

	0 2swap strcat 2swap strcat
	2dup modulepath setenv

	drop free if ( freeing memory error )
	  2drop
	  2r> restoreenv
	  100 exit
	then

	\ Now, once more, try to load the kernel
	s" load ${kernel} ${kernel_options}" ['] evaluate catch
	if ( failed once more )
	  2drop
	  2r> restoreenv
	  100 exit
	then

      else ( we found the kernel on the path passed )

	2drop ( discard command line arguments )

      then ( could not load kernel from directory passed )

      \ Load the remaining modules, if the kernel was loaded at all
      ['] load_modules catch if 2r> restoreenv 100 exit then

      \ Call autoboot to perform the booting
      0 1 autoboot

      \ Keep new module_path
      2r> freeenv

      exit
    then ( could not load kernel with name passed )

    2drop ( discard command line arguments )

  else ( try just a straight-forward kernel load )
    s" load ${kernel} ${kernel_options}" ['] evaluate catch
    if ( kernel load failed ) 2drop 100 exit then

  then ( there are command line arguments )

  \ Load the remaining modules, if the kernel was loaded at all
  ['] load_modules catch if 100 exit then

  \ Call autoboot to perform the booting
  0 1 autoboot
;

also forth definitions
builtin: boot-conf
only forth definitions also support-functions

\ ***** check-password
\
\	If a password was defined, execute autoboot and ask for
\	password if autoboot returns.

: check-password
  password .addr @ if
    0 autoboot
    false >r
    begin
      bell emit bell emit
      ." Password: "
      password .len @ read-password
      dup password .len @ = if
        2dup password .addr @ password .len @
        compare 0= if r> drop true >r then
      then
      drop free drop
      r@
    until
    r> drop
  then
;

\ ***** start
\
\       Initializes support.4th global variables, sets loader_conf_files,
\       process conf files, and, if any one such file was succesfully
\       read to the end, load kernel and modules.

: start  ( -- ) ( throws: abort & user-defined )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  \ Will *NOT* try to load kernel and modules if no configuration file
  \ was succesfully loaded!
  any_conf_read? if
    load_kernel
    load_modules
  then
;

\ ***** initialize
\
\	Overrides support.4th initialization word with one that does
\	everything start one does, short of loading the kernel and
\	modules. Returns a flag

: initialize ( -- flag )
  s" /boot/defaults/loader.conf" initialize
  include_conf_files
  any_conf_read?
;

\ ***** read-conf
\
\	Read a configuration file, whose name was specified on the command
\	line, if interpreted, or given on the stack, if compiled in.

: (read-conf)  ( addr len -- )
  conf_files .addr @ ?dup if free abort" Fatal error freeing memory" then
  strdup conf_files .len ! conf_files .addr !
  include_conf_files \ Will recurse on new loader_conf_files definitions
;

: read-conf  ( <filename> | addr len -- ) ( throws: abort & user-defined )
  state @ if
    \ Compiling
    postpone (read-conf)
  else
    \ Interpreting
    bl parse (read-conf)
  then
; immediate

\ ***** enable-module
\
\       Turn a module loading on.

: enable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      true r> module.flag !
      ."  will be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** disable-module
\
\       Turn a module loading off.

: disable-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      false r> module.flag !
      ."  will not be loaded." cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** toggle-module
\
\       Turn a module loading on/off.

: toggle-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      r@ module.name dup .addr @ swap .len @ type
      r@ module.flag @ 0= dup r> module.flag !
      if
        ."  will be loaded." cr
      else
        ."  will not be loaded." cr
      then
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ ***** show-module
\
\	Show loading information about a module.

: show-module ( <module> -- )
  bl parse module_options @ >r
  begin
    r@
  while
    2dup
    r@ module.name dup .addr @ swap .len @
    compare 0= if
      2drop
      ." Name: " r@ module.name dup .addr @ swap .len @ type cr
      ." Path: " r@ module.loadname dup .addr @ swap .len @ type cr
      ." Type: " r@ module.type dup .addr @ swap .len @ type cr
      ." Flags: " r@ module.args dup .addr @ swap .len @ type cr
      ." Before load: " r@ module.beforeload dup .addr @ swap .len @ type cr
      ." After load: " r@ module.afterload dup .addr @ swap .len @ type cr
      ." Error: " r@ module.loaderror dup .addr @ swap .len @ type cr
      ." Status: " r> module.flag @ if ." Load" else ." Don't load" then cr
      exit
    then
    r> module.next @ >r
  repeat
  r> drop
  type ."  wasn't found." cr
;

\ Words to be used inside configuration files

: retry false ;         \ For use in load error commands
: ignore true ;         \ For use in load error commands

\ Return to strict forth vocabulary

only forth also


Switch to callbacks for outgoing flow control.

\ 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.
	DUP >R (seremitfc)
	0<> IF 1 cnt.pause +!
		self tcb.bbstatus @ R> 0 setiocallback drop   stop
		else R> DROP 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-basic)
	begin pause
	dup (serkey?) until
	(sergetchar)
;

: (serkey-sleep?)
	self tcb.bbstatus @ over 1 setiocallback drop ( base )
	self halt
	dup (serkey?) IF self restart ELSE PAUSE THEN \ We are now armed and ready to block
    (serkey?)
;

\ *G Wait for a character to come available on the given UART and
\ ** return the character.
\ Advanced usage - Register a callback.
\ The tricky part is not screwing things up by missing a character
\ in the window between when you register, and when you pick up your
\ character.   The way to do that is by registering, then self
\ halting, and then checking for a new character.  That ensures that
\ if a character has slipped in, you will catch it.
: (serkey)	\ base -- char
	begin dup (serkey-sleep?) 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 +! #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-basic)
	begin pause
	dup (serkey?) until
	(sergetchar)
;

: (serkey-sleep?)
	self tcb.bbstatus @ over 1 setiocallback drop ( base )
	self halt
	dup (serkey?) IF self restart ELSE PAUSE THEN \ We are now armed and ready to block
    (serkey?)
;

\ *G Wait for a character to come available on the given UART and
\ ** return the character.
\ Advanced usage - Register a callback.
\ The tricky part is not screwing things up by missing a character
\ in the window between when you register, and when you pick up your
\ character.   The way to do that is by registering, then self
\ halting, and then checking for a new character.  That ensures that
\ if a character has slipped in, you will catch it.
: (serkey)	\ base -- char
	begin dup (serkey-sleep?) 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