Hooks for collecting IO stats.

Hooks for collecting IO stats.

\ serCM3_sapi_level1.fth - SAPI polled RX, polled TX, serial communication drivers
\ with support for blocking IO.
\ Written to run against the SockPuppet API.

\ Level 1 support.   Requires TASKING.  System calls request blocking.
\ KEY requires blocking, so that must be implemented here.

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

only forth definitions

\ ==============
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.   This is
\ ** The simplest implementation level.
\ ** It doesn't use the CR or TYPE calls, but rather emulates them.

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

target

[defined] IOProfiling? [if]
variable c_emit
variable c_type
variable c_type_chars
variable c_cr
variable c_key
[then]

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

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

target

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

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run, or just does a WFI if no multitasker.
\ The only interesting thing is failure, or -1.  That means retry.
	\ 1 c_emit +!
    (seremitfc) if [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] then
	;

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
  \ 1 c_type +!
  \ over c_type_chars +!

  -rot bounds
  ?do  i c@ over (seremit)  loop
  drop
;

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

: (serkey) \ base -- c
\ *G Get a character from the port.  Retry until we get it.
\ The system call will stop the task and restart it when there is data.
\ See if its negative.  If so, discard it and leave false to re-loop.
\ If not negative, leave true on the stack to exit.
    begin \ base ret t/f
	dup (serkeyfc) dup 0 <  \ base ret t/f
	 \ If we have been blocked, drop the useless returned data and try again.
	 IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] drop false
	 ELSE true \ Leave the return code intact.
	 THEN \ base ret t/f
	until  \ base ret
	swap drop
    \ 1 c_key +!
;

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

external

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

\ --------------------------------------------------------------------
\ Optional devices
\ --------------------------------------------------------------------
[defined] useUART1? [if]   useUART1? 1 = [if]
: seremit1 #1 (seremit)  ;
: sertype1 #1 (sertype)  ;
: sercr1   #1 (sercr)  ;
: serkey?1 #1 (serkey?)  ;
: serkey1  #1 (serkey)  ;
create Console1 ' serkey1 , ' serkey?1 , ' seremit1 , ' sertype1 , ' sercr1 ,
[then]  [then]

\ --------------------------------------------------------------------
\ Non-UARTs.
\ --------------------------------------------------------------------
[defined] useStream10? [if]    useStream10? 1 = [if]
: seremit10 #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,
[then]  [then]

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

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

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

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

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

decimal

\ serCM3_sapi_level1.fth - SAPI polled RX, polled TX, serial communication drivers
\ with support for blocking IO.
\ Written to run against the SockPuppet API.

\ Level 1 support.   Requires TASKING.  System calls request blocking.
\ KEY requires blocking, so that must be implemented here.

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

only forth definitions

\ ==============
\ *T SAPI polled serial driver
\ ==============
\ *P This driver provides polled serial comms for Cortex-M3 CPUs
\ ** using the internal UARTs via the SAPI call layer.   This is
\ ** The simplest implementation level.
\ ** It doesn't use the CR or TYPE calls, but rather emulates them.

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

target

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

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

target

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

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run, or just does a WFI if no multitasker.
\ The only interesting thing is failure, or -1.  That means retry.
    (seremitfc) if [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] 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)
;

: (serkey) \ base -- c
\ *G Get a character from the port.  Retry until we get it.
\ The system call will stop the task and restart it when there is data.
\ See if its negative.  If so, discard it and leave false to re-loop.
\ If not negative, leave true on the stack to exit.
    begin \ base ret t/f
	dup (serkeyfc) dup 0 <  \ base ret t/f
	 \ If we have been blocked, drop the useless returned data and try again.
	 IF [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then] drop false
	 ELSE true \ Leave the return code intact.
	 THEN \ base ret t/f
	until  \ base ret
	swap drop
;

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

external

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

\ --------------------------------------------------------------------
\ Optional devices
\ --------------------------------------------------------------------
[defined] useUART1? [if]   useUART1? 1 = [if]
: seremit1 #1 (seremit)  ;
: sertype1 #1 (sertype)  ;
: sercr1   #1 (sercr)  ;
: serkey?1 #1 (serkey?)  ;
: serkey1  #1 (serkey)  ;
create Console1 ' serkey1 , ' serkey?1 , ' seremit1 , ' sertype1 , ' sercr1 ,
[then]  [then]

\ --------------------------------------------------------------------
\ Non-UARTs.
\ --------------------------------------------------------------------
[defined] useStream10? [if]    useStream10? 1 = [if]
: seremit10 #10 (seremit)  ;
: sertype10	#10 (sertype)  ;
: sercr10	#10 (sercr)  ;
: serkey?10	#10 (serkey?)  ;
: serkey10	#10 (serkey)  ;
create Console10 ' serkey10 , ' serkey?10 , ' seremit10 , ' sertype10 , ' sercr10 ,
[then]  [then]

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

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

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

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

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

decimal


Removed NIP, TUCK and -ROT

Removed NIP, TUCK and -ROT

( block 1  -- Main load block )

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

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

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

( block 100 )

1 FH 6 FH THRU

( shadow 100 )
( block 101 stack primitives )

: ROT   >R SWAP R> SWAP ;
\ : -ROT  SWAP >R SWAP R> ;  \ or ROT ROT
: ?DUP  DUP IF DUP THEN ;
\ : 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 101 )
( block 102  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 102 )
( block 103 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 103 )
( block 104  variables )

VARIABLE BASE
: DECIMAL 10 BASE ! ;   : HEX 16 BASE ! ;
( shadow 104 )
( block 105 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 105 )
( block 106  math continued )

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

: 2* DUP + ;
\ 2/ which is right shift is native
( shadow 106 )
( block 107 )
( shadow 107 )
( block 108 )
( shadow 108 )
( block 109 )
( shadow 109 )
( block 110 compiler )

: VARIABLE CREATE 1 CELLS ALLOT ;

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

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

( shadow 110 )
( block 111 )
( shadow 111 )
( block 112 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 112 )

( block 1  -- Main load block )

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

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

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

( block 100 )

1 FH 6 FH THRU

( shadow 100 )
( block 101 stack primitives )

: ROT   >R SWAP R> SWAP ;
: -ROT  SWAP >R SWAP R> ;  \ or ROT ROT
: ?DUP  DUP IF DUP THEN ;
: 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 101 )
( block 102  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 102 )
( block 103 ALU )

: 1+  1 + ;
: 1-  1 - ;
: INVERT  TRUE XOR ;
: NEGATE  INVERT 1+ ;
: DNEGATE  INVERT SWAP NEGATE TUCK 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 103 )
( block 104  variables )

VARIABLE BASE
: DECIMAL 10 BASE ! ;   : HEX 16 BASE ! ;
( shadow 104 )
( block 105 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 NIP ;

( shadow 105 )
( block 106  math continued )

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

: 2* DUP + ;
\ 2/ which is right shift is native
( shadow 106 )
( block 107 )
( shadow 107 )
( block 108 )
( shadow 108 )
( block 109 )
( shadow 109 )
( block 110 compiler )

: VARIABLE CREATE 1 CELLS ALLOT ;

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

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

( shadow 110 )
( block 111 )
( shadow 111 )
( block 112 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 112 )


Prevent SAVE-FORTH from asking user Y/N

Prevent SAVE-FORTH from asking user Y/N

\ %Z% %M% %E% %I%
\ make_hmsl.fth
\ Create HMSL dictionary

include fth/load_hmsl.fth

\ Do not execute auto.init chain if stack is large.
\ This is a hack so that SAVE-FORTH won't trigger HMSL.INIT,
\ which asks the user Y/N, which messes up the XCode build script.
\ We have to block this using the stack because if
\ we used a variable, the variable value would get saved in the dictionary
\ preventing HMSL.INIT when HMSL was run.
: AUTO.INIT ( -- )
    depth 4 > IF
        ." AUTO.INIT disabled because DEPTH > 4." cr
        .S
	ELSE
        auto.init
    THEN
;

." Block AUTO.INIT that is called by SAVE-FORTH" cr
1 2 3 4 5 6
c" pforth.dic" save-forth
6 0 DO drop LOOP

\ %Z% %M% %E% %I%
\ make_hmsl.fth
\ Create HMSL dictionary

include fth/load_hmsl.fth
c" pforth.dic" save-forth


Update SysCalls.ft for M0 Compatibility. Remove the support for passing in a zero'd TCB pointer.


Directly call the 'reboot' word instead of indirectly evaluating it.

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ 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/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

variable bootkey
variable bootacpikey
variable bootsafekey
variable bootverbosekey
variable bootsinglekey
variable escapekey
variable rebootkey

46 constant dot

\ The BSD Daemon.  He is 19 rows high and 34 columns wide
: technicolor-beastie ( x y -- )
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 ."         `--{__________) " 1+
;

: boring-beastie ( x y -- )
	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 ."        `--{__________)"
;

: print-beastie ( x y -- )
	s" loader_color" getenv
	dup -1 = if
		drop
		boring-beastie
		exit
	then
	s" YES" compare-insensitive 0<> if
		boring-beastie
		exit
	then
	technicolor-beastie
;

: acpienabled? ( -- flag )
	s" acpi_load" getenv
	dup -1 = if
		drop false exit
	then
	s" YES" compare-insensitive 0<> if
		false exit
	then
	s" hint.acpi.0.disabled" getenv
	dup -1 <> if
		s" 0" compare 0<> if
			false exit
		then
	then
	true
;

: printmenuitem ( -- n )
	menuidx @
	1+ dup
	menuidx !
	menuY @ + dup menuX @ swap at-xy
	menuidx @ .
	menuX @ 1+ swap at-xy
	menubllt @ emit
	menuidx @ 48 +
;

: beastie-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	46 4 print-beastie
	42 20 2 2 box
	13 6 at-xy ." Welcome to FreeBSD!"
	printmenuitem ."  Boot FreeBSD [default]" bootkey !
	s" arch-i386" environment? if
		printmenuitem ."  Boot FreeBSD with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot FreeBSD in Safe Mode" bootsafekey !
	printmenuitem ."  Boot FreeBSD in single user mode" bootsinglekey !
	printmenuitem ."  Boot FreeBSD with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

: tkey
	dup
	seconds +
	begin 1 while
		over 0<> if
			dup seconds u< if
				drop
				-1
				exit
			then
			menuX @ promptwidth @ + 21 at-xy dup seconds - .
		then
		key? if
			drop
			key
			exit
		then
	50 ms
	repeat
;

set-current

: beastie-start
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	then
	beastie-menu
	s" autoboot_delay" getenv
	dup -1 = if
		drop
		10
	else
		0 0 2swap >number drop drop drop
	then
	begin true while
		dup tkey
		0 25 at-xy
		dup 32 = if nip 0 swap then
		dup -1 = if 0 boot then
		dup 13 = if 0 boot then
		dup bootkey @ = if 0 boot then
		dup bootacpikey @ = if
			acpienabled? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			else
				s" YES" s" acpi_load" setenv
				s" 0" s" hint.acpi.0.disabled" setenv
			then
			0 boot
		then
		dup bootsafekey @ = if
			s" arch-i386" environment? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			then
			s" 0" s" hw.ata.ata_dma" setenv
			s" 0" s" hw.ata.atapi_dma" setenv
			s" 0" s" hw.ata.wc" setenv
			s" 0" s" hw.eisa_slots" setenv
			0 boot
		then
		dup bootverbosekey @ = if
			s" YES" s" boot_verbose" setenv
			0 boot
		then
		dup bootsinglekey @ = if
			s" YES" s" boot_single" setenv
			0 boot
		then
		dup escapekey @ = if
			2drop
			s" NO" s" autoboot_delay" setenv
			exit
		then
		rebootkey @ = if 0 reboot then
	repeat
;

previous

\ Copyright (c) 2003 Scott Long <scottl@freebsd.org>
\ Copyright (c) 2003 Aleksander Fafula <alex@fafula.com>
\ 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/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

variable bootkey
variable bootacpikey
variable bootsafekey
variable bootverbosekey
variable bootsinglekey
variable escapekey
variable rebootkey

46 constant dot

\ The BSD Daemon.  He is 19 rows high and 34 columns wide
: technicolor-beastie ( x y -- )
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 ."         `--{__________) " 1+
;

: boring-beastie ( x y -- )
	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 ."        `--{__________)"
;

: print-beastie ( x y -- )
	s" loader_color" getenv
	dup -1 = if
		drop
		boring-beastie
		exit
	then
	s" YES" compare-insensitive 0<> if
		boring-beastie
		exit
	then
	technicolor-beastie
;

: acpienabled? ( -- flag )
	s" acpi_load" getenv
	dup -1 = if
		drop false exit
	then
	s" YES" compare-insensitive 0<> if
		false exit
	then
	s" hint.acpi.0.disabled" getenv
	dup -1 <> if
		s" 0" compare 0<> if
			false exit
		then
	then
	true
;

: printmenuitem ( -- n )
	menuidx @
	1+ dup
	menuidx !
	menuY @ + dup menuX @ swap at-xy
	menuidx @ .
	menuX @ 1+ swap at-xy
	menubllt @ emit
	menuidx @ 48 +
;

: beastie-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	46 4 print-beastie
	42 20 2 2 box
	13 6 at-xy ." Welcome to FreeBSD!"
	printmenuitem ."  Boot FreeBSD [default]" bootkey !
	s" arch-i386" environment? if
		printmenuitem ."  Boot FreeBSD with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot FreeBSD in Safe Mode" bootsafekey !
	printmenuitem ."  Boot FreeBSD in single user mode" bootsinglekey !
	printmenuitem ."  Boot FreeBSD with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

: tkey
	dup
	seconds +
	begin 1 while
		over 0<> if
			dup seconds u< if
				drop
				-1
				exit
			then
			menuX @ promptwidth @ + 21 at-xy dup seconds - .
		then
		key? if
			drop
			key
			exit
		then
	50 ms
	repeat
;

set-current

: beastie-start
	s" beastie_disable" getenv
	dup -1 <> if
		s" YES" compare-insensitive 0= if
			exit
		then
	then
	beastie-menu
	s" autoboot_delay" getenv
	dup -1 = if
		drop
		10
	else
		0 0 2swap >number drop drop drop
	then
	begin true while
		dup tkey
		0 25 at-xy
		dup 32 = if nip 0 swap then
		dup -1 = if 0 boot then
		dup 13 = if 0 boot then
		dup bootkey @ = if 0 boot then
		dup bootacpikey @ = if
			acpienabled? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			else
				s" YES" s" acpi_load" setenv
				s" 0" s" hint.acpi.0.disabled" setenv
			then
			0 boot
		then
		dup bootsafekey @ = if
			s" arch-i386" environment? if
				s" acpi_load" unsetenv
				s" 1" s" hint.acpi.0.disabled" setenv
				s" 1" s" loader.acpi_disabled_by_user" setenv
			then
			s" 0" s" hw.ata.ata_dma" setenv
			s" 0" s" hw.ata.atapi_dma" setenv
			s" 0" s" hw.ata.wc" setenv
			s" 0" s" hw.eisa_slots" setenv
			0 boot
		then
		dup bootverbosekey @ = if
			s" YES" s" boot_verbose" setenv
			0 boot
		then
		dup bootsinglekey @ = if
			s" YES" s" boot_single" setenv
			0 boot
		then
		dup escapekey @ = if
			2drop
			s" NO" s" autoboot_delay" setenv
			exit
		then
		rebootkey @ = if s" reboot" evaluate then
	repeat
;

previous


DEC2BIN added (not working)

DEC2BIN added (not working)

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

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

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


9 seconds for 4 x 4 puzzle, not bad for a language that's not going to get any optimization in the gnu toolset. I could probably shave a second or two off that by being more efficient with when I store things in memory instead of just always doing it, but I think this is an adequate effort for now. Plus I have that same behavior in the c version.

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

create choices   1 ,  2 ,  3 ,  4 ,
                 5 ,  6 ,  7 ,  8 ,
                 9 , 10 , 11 , 12 ,
                13 , 14 , 15 , 16 ,

variable picked size allot
variable additional-constraints size cells allot

: clear-picked
    size 0 do
        0 i picked + C!
    loop ;

: print-picked
    size 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 width mod wm = 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 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 ;


Apparently you have to define structures before they get used.

(( 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 ( -- )
  #1000 needlemax
  2dup ! 4 + 2dup ! 4 +  !
  interp-init
;

\ ----------------------------------------------------------
\ Define the structures before they get used.
\ ----------------------------------------------------------
struct ODN \ On-Deck Needle
	2 field odn.s
	2 field odn.m
	2 field 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

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
idata
create NEEDLEMAX 3 cells allot
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

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

	interp_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!
  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

\ Heres the default values.   These are universal.
idata
create interp_max #850 , #850 , #850 ,
cdata

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

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

  (interp_init) interp_dhms
  2dup interp.a interp_max     @  raw_dsec call3--
  2dup interp.b interp_max 4 + @      #100 call3--
       interp.c interp_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 hms advancetime then
   	dup inter.rtcdsem @offex! ?dup if dhms advancetime then
    [asm wfi asm]
    uiupdate if use-uivals else use-clockvals then
  key? until drop
;

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

\ ----------------------------------------------------------
\ Needle Management
\ ----------------------------------------------------------
struct ODN
	2 field odn.s
	2 field odn.m
	2 field odn.h
end-struct

udata
create NEEDLEMAX 3 cells allot
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

: 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.
	interp_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
	\ the zero resets on every needle sweep.
    rangecheck ?dup 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!
  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.
\ ----------------------------------------------------------
struct _HMS
	int hms.subsec
	int hms.s
	int hms.m
	int hms.h
	int hms.maxsubsec \ Max Value for subseconds
	int hms.maxsec   \ Max Value for secs+minutes
	int hms.maxhour   \ Max for hours
	ptr hms.w_s    \ Increment the seconds value
	ptr hms.w_m    \ increment the minutes + hours
end-struct

idata
create HMS
  0 , 0 , 0 , 0 , \ Running Counters
  #16 , #60 , #24 , \ Limits
  ' ++needle_s , ' ++needle_m , \ Words to invoke
create DHMS
  0 , 0 , 0 , 0 , \ Running Counters
  #10 , #100 , #10 , \ Limits
' ++needle_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
\ ----------------------------------------------------------
struct _interp_set
	4 cells field interp.a
	4 cells field interp.b
	4 cells field interp.c
end-struct

udata
create interp_hms  _interp_set allot
create interp_dhms _interp_set allot
create adj_list #50 cells allot \ 100 16-bit words.
cdata

\ Heres the default values.   These are universal.
idata
create interp_max #850 , #850 , #850 ,
cdata

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

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

  (interp_init) interp_dhms
  2dup interp.a interp_max     @  raw_dsec call3--
  2dup interp.b interp_max 4 + @      #100 call3--
       interp.c interp_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 ,


Make things a bit more concise.

Make things a bit more concise.

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

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

only forth definitions

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

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

target

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

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

target

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

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

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
\ * The system call wants     base len caddr
	>R  \ We'll use this a few times.
	begin
	2dup R@ (sertypefc)  dup \ caddr len ret ret
	IF
	  [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then]
	  dup >R - swap R> + swap \ Advance the caddr len pair
	THEN
	0= until
	2drop
	R> drop
;

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

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

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

external

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

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

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

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

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

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

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

decimal

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

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

only forth definitions

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

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

target

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

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

target

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

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

: (sertype) \ caddr len base --
\ *G Transmit a string on the given UART.
\ * The system call wants     base len caddr
	>R  \ We'll use this a few times.
	begin
	2dup R@ (sertypefc)  dup \ caddr len ret ret
	IF
	  [ tasking? ] [if] PAUSE [else] [asm wfi asm] [then]
	  dup >R - swap R> + swap \ Advance the caddr len pair
	THEN
	0= until
	2drop
	R> drop
;

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

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

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

external

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

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

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

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

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

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

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

decimal