Moved prelude

Moved prelude

( : over ; )
( : rot ; )
( : nip swap drop ; )
( : -rot rot rot ; )
( : tuck swap over ; )

( : sq dup * ; )

: 2dup over over ;
: 3dup 2dup dup ;
: 2drop drop drop ;
: 3drop 2drop drop ;

: min 2dup > if swap then drop ; ( not used? )
: max 2dup < if swap then drop ; ( not used? )
: between rot swap over >= -rot <= and ;
: +! dup @ rot + swap ! ;
3.14159265359 const pi
pi 2 * const 2pi ( not used? )
pi 180 / const d2r
: deg2rad d2r * ;

: repeat 0 do ;

: neg -1 * ;
: abs dup 0 < if neg then ;


in reverse() for empty list, return a copy insead of self

class List <T?>

#> Represents a list with an event number of elements, treated as pairs.
#| This is similar to a hash with ordered keys.
type Pairs {
    isa *class
    satisfies .length.even
}

#> True if the list is empty.
.empty -> @length == 0

#> Returns a copy of the list by mapping each element to another value based on
#| a transformation code.
.map {
    need $code: Code
    -> gather for $el in *self {
        take $code($el)
    }
}

#> Returns a copy of the list containing only the elements that satisfy a code.
.grep {
    need $code: Code
    -> gather for $el in *self {
        if $code($el): take $el
    }
}

#> Returns a flattened copy of the list.
method flatten {
    $new = []
    for $el in *self {
        if $el.*isa(List)
            $new.push(items: $el.flatten())
        else
            $new.push($el)
    }
    -> $new
}

#> Returns a reversed copy of the list.
method reverse {
    if @empty
        -> @copy()
    -> gather for $i in @lastIndex..0:
        take *self[$i]
}

#> Copies the list, ignoring all possible occurrences of a specified value.
method withoutAll {
    need $what
    -> @grep! { -> $what != $_ }
    # -> @grep(func { -> $what != $_ })
}

#> Copies the list, ignoring the first occurrence of a specified value.
method without {
    need $what
    var $found
    -> gather for ($i, $el) in *self {
        if !$found && $what == $el {
            $found = true
            next
        }
        take $el
    }
}

#> Removes the first element equal to a specified value.
method remove {
    need $what
    removed -> false
    for ($i, $el) in *self {
        if $what != $el
            next
        @splice($i, 1)
        removed -> true
        last
    }
}

#> Removes all elements equal to a specified value.
method removeAll {
    need $what

    # find the indices at which the value occurs
    $indices = gather for ($i, $el) in *self {
        if $what != $el
            next
        take $i
    }

    # remove
    for $i in $indices.reverse!
        @splice($i, 1)

    removed -> $indices.length    #< number of removed elements
}

#> Returns true if the list contains at least one occurrence of the provided
#| value.
method contains {
    need $what
    -> @any! { -> $what == $_ }
}

#> Finds the first element to satisfy a code.
method first {
    need $code: Code
    for $el in *self {
        if $code($el): -> $el
    }
    -> undefined
}

#> Returns the index of the first occurrence of the given value
method indexOf {
    need $what
    for ($i, $el) in *self {
        if $what == $el: -> $i
    }
    -> undefined
}

#> Returns true if at least one element satisfies a code.
method any {
    need $code: Code
    for $el in *self {
        if $code($el): -> true
    }
    -> false
}

#> Returns true if all elements satisfy a code.
method all {
    need $code: Code
    for $el in *self {
        if !$code($el): -> false
    }
    -> true
}

#> Returns the sum of all elements in the list or `undefined` if the list is
#| empty.
.sum {
    if @empty
        -> undefined
    $c = *self[0]
    for $i in 1 .. @lastIndex {
        $c = $c + *self[$i]
    }
    -> $c
}

#> Returns the sum of all elements in the list or `0` (zero) if the list is
#| empty. Useful for lists of numbers.
.sum0 {
    $c = 0
    for $el in *self {
        $c = $c + $el
    }
    -> $c
}

#> Returns the first element in the list.
.firstItem -> *self[0]

#> Returns the last element in the list.
.lastItem -> *self[@lastIndex]

#> If the list has length one, returns an empty string, otherwise `"s"`
.s {
    if @length == 1
        -> ""
    -> "s"
}

#> Returns an iterator for the list. This allows lists to be used in a for loop.
.iterator -> ListIterator(*self) : Iterator

#> Adding lists together results in an ordered consolidation of the lists.
op + {
    need $rhs: List
    $new = @copy()
    $new.push(items: $rhs)
    -> $new
}

#> Subtracting list B from list A results in a new list containing all elements
#| found in A but not found in B. Example: `[1,2,3,4,5] - [3,5]` -> `[1,2,4]`.
op - {
    need $rhs: List
    $new = @copy()
    for $remove in $rhs:
        $new.removeAll($remove)
    -> $new
}

#> Lists are equal if all the elements are equal and in the same order.
op == {
    need $ehs: List

    # first check if length is same
    if @length != $ehs.length
        -> false

    # check each item
    for ($i, $val) in *self {
        if $ehs[$i] != $val
            -> false
    }

    -> true
}

#> Lists are equal to their numerical length.
op == {
    need $ehs: Num
    -> @length == $ehs
}

#> Lists are greater than numbers smaller than their length.
op > {
    need $rhs: Num
    -> @length > $rhs
}

#> Lists are smaller than numbers greater than their length.
op < {
    need $rhs: Num
    -> @length < $rhs
}

#> Lists are greater than numbers smaller than their length.
op > {
    need $lhs: Num
    -> @length < $lhs
}

#> Lists are smaller than numbers greater than their length.
op < {
    need $lhs: Num
    -> @length > $lhs
}

# Iterator methods

.iterator -> *self

method reset {
    @i = -1
}

.more -> @i < (@lastIndex || -1)

.nextElement {
    @i += 1
    -> *self[@i]
}

.nextElements {
    @i += 1
    -> [ @i, *self[@i] ]
}

class List <T?>

#> Represents a list with an event number of elements, treated as pairs.
#| This is similar to a hash with ordered keys.
type Pairs {
    isa *class
    satisfies .length.even
}

#> True if the list is empty.
.empty -> @length == 0

#> Returns a copy of the list by mapping each element to another value based on
#| a transformation code.
.map {
    need $code: Code
    -> gather for $el in *self {
        take $code($el)
    }
}

#> Returns a copy of the list containing only the elements that satisfy a code.
.grep {
    need $code: Code
    -> gather for $el in *self {
        if $code($el): take $el
    }
}

#> Returns a flattened copy of the list.
method flatten {
    $new = []
    for $el in *self {
        if $el.*isa(List)
            $new.push(items: $el.flatten())
        else
            $new.push($el)
    }
    -> $new
}

#> Returns a reversed copy of the list.
method reverse {
    if @empty
        -> *self
    -> gather for $i in @lastIndex..0:
        take *self[$i]
}

#> Copies the list, ignoring all possible occurrences of a specified value.
method withoutAll {
    need $what
    -> @grep! { -> $what != $_ }
    # -> @grep(func { -> $what != $_ })
}

#> Copies the list, ignoring the first occurrence of a specified value.
method without {
    need $what
    var $found
    -> gather for ($i, $el) in *self {
        if !$found && $what == $el {
            $found = true
            next
        }
        take $el
    }
}

#> Removes the first element equal to a specified value.
method remove {
    need $what
    removed -> false
    for ($i, $el) in *self {
        if $what != $el
            next
        @splice($i, 1)
        removed -> true
        last
    }
}

#> Removes all elements equal to a specified value.
method removeAll {
    need $what

    # find the indices at which the value occurs
    $indices = gather for ($i, $el) in *self {
        if $what != $el
            next
        take $i
    }

    # remove
    for $i in $indices.reverse!
        @splice($i, 1)

    removed -> $indices.length    #< number of removed elements
}

#> Returns true if the list contains at least one occurrence of the provided
#| value.
method contains {
    need $what
    -> @any! { -> $what == $_ }
}

#> Finds the first element to satisfy a code.
method first {
    need $code: Code
    for $el in *self {
        if $code($el): -> $el
    }
    -> undefined
}

#> Returns the index of the first occurrence of the given value
method indexOf {
    need $what
    for ($i, $el) in *self {
        if $what == $el: -> $i
    }
    -> undefined
}

#> Returns true if at least one element satisfies a code.
method any {
    need $code: Code
    for $el in *self {
        if $code($el): -> true
    }
    -> false
}

#> Returns true if all elements satisfy a code.
method all {
    need $code: Code
    for $el in *self {
        if !$code($el): -> false
    }
    -> true
}

#> Returns the sum of all elements in the list or `undefined` if the list is
#| empty.
.sum {
    if @empty
        -> undefined
    $c = *self[0]
    for $i in 1 .. @lastIndex {
        $c = $c + *self[$i]
    }
    -> $c
}

#> Returns the sum of all elements in the list or `0` (zero) if the list is
#| empty. Useful for lists of numbers.
.sum0 {
    $c = 0
    for $el in *self {
        $c = $c + $el
    }
    -> $c
}

#> Returns the first element in the list.
.firstItem -> *self[0]

#> Returns the last element in the list.
.lastItem -> *self[@lastIndex]

#> If the list has length one, returns an empty string, otherwise `"s"`
.s {
    if @length == 1
        -> ""
    -> "s"
}

#> Returns an iterator for the list. This allows lists to be used in a for loop.
.iterator -> ListIterator(*self) : Iterator

#> Adding lists together results in an ordered consolidation of the lists.
op + {
    need $rhs: List
    $new = @copy()
    $new.push(items: $rhs)
    -> $new
}

#> Subtracting list B from list A results in a new list containing all elements
#| found in A but not found in B. Example: `[1,2,3,4,5] - [3,5]` -> `[1,2,4]`.
op - {
    need $rhs: List
    $new = @copy()
    for $remove in $rhs:
        $new.removeAll($remove)
    -> $new
}

#> Lists are equal if all the elements are equal and in the same order.
op == {
    need $ehs: List

    # first check if length is same
    if @length != $ehs.length
        -> false

    # check each item
    for ($i, $val) in *self {
        if $ehs[$i] != $val
            -> false
    }

    -> true
}

#> Lists are equal to their numerical length.
op == {
    need $ehs: Num
    -> @length == $ehs
}

#> Lists are greater than numbers smaller than their length.
op > {
    need $rhs: Num
    -> @length > $rhs
}

#> Lists are smaller than numbers greater than their length.
op < {
    need $rhs: Num
    -> @length < $rhs
}

#> Lists are greater than numbers smaller than their length.
op > {
    need $lhs: Num
    -> @length < $lhs
}

#> Lists are smaller than numbers greater than their length.
op < {
    need $lhs: Num
    -> @length > $lhs
}

# Iterator methods

.iterator -> *self

method reset {
    @i = -1
}

.more -> @i < (@lastIndex || -1)

.nextElement {
    @i += 1
    -> *self[@i]
}

.nextElements {
    @i += 1
    -> [ @i, *self[@i] ]
}


?NOT-TWO-ADJACENT-1-BITS tests added

?NOT-TWO-ADJACENT-1-BITS tests added

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

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT

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

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

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

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

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

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

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

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

\ ---- tests ----

ASSERTS-INIT

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

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

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

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

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

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

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

REQUIRE KataDiversion.fth

VARIABLE ASSERT-COUNT

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

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

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

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

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

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

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

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

\ ---- tests ----

ASSERTS-INIT

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

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

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

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

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


Cleanup.

Cleanup.

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

0 value sercallback

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 oldcb )
	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
\ ********************

0 value sercallback

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 oldcb )
	self halt
	dup (serkey?) IF self restart ELSE PAUSE THEN \ We are now armed and ready to block
;

\ 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-callback)
	begin dup (serkey-sleep?) until (sergetchar)
;

: (serkey)	\ base -- char
\ *G Wait for a character to come available on the given UART and
\ ** return the character.
	sercallback IF (serkey-callback) ELSE (serkey-basic) THEN
;

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


?TWO-ADJACENT-1-BITS removed

?TWO-ADJACENT-1-BITS removed

\ KataDiversion in Forth

\ -- utils

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

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

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

\ -- kata

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

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

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

\ KataDiversion in Forth

\ -- utils

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

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

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

\ -- kata

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

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

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

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


Pull an unused value.

Pull an unused value.

\ 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

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

0 value sercallback

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


list comparison to number checks against length

class List <T?>

#> Represents a list with an event number of elements, treated as pairs.
#| This is similar to a hash with ordered keys.
type Pairs {
    isa *class
    satisfies .length.even
}

#> True if the list is empty.
.empty -> @length == 0

#> Returns a copy of the list by mapping each element to another value based on
#| a transformation code.
.map {
    need $code: Code
    -> gather for $el in *self {
        take $code($el)
    }
}

#> Returns a copy of the list containing only the elements that satisfy a code.
.grep {
    need $code: Code
    -> gather for $el in *self {
        if $code($el): take $el
    }
}

#> Returns a flattened copy of the list.
method flatten {
    $new = []
    for $el in *self {
        if $el.*isa(List)
            $new.push(items: $el.flatten())
        else
            $new.push($el)
    }
    -> $new
}

#> Returns a reversed copy of the list.
method reverse {
    if @empty
        -> *self
    -> gather for $i in @lastIndex..0:
        take *self[$i]
}

#> Copies the list, ignoring all possible occurrences of a specified value.
method withoutAll {
    need $what
    -> @grep! { -> $what != $_ }
    # -> @grep(func { -> $what != $_ })
}

#> Copies the list, ignoring the first occurrence of a specified value.
method without {
    need $what
    var $found
    -> gather for ($i, $el) in *self {
        if !$found && $what == $el {
            $found = true
            next
        }
        take $el
    }
}

#> Removes the first element equal to a specified value.
method remove {
    need $what
    removed -> false
    for ($i, $el) in *self {
        if $what != $el
            next
        @splice($i, 1)
        removed -> true
        last
    }
}

#> Removes all elements equal to a specified value.
method removeAll {
    need $what

    # find the indices at which the value occurs
    $indices = gather for ($i, $el) in *self {
        if $what != $el
            next
        take $i
    }

    # remove
    for $i in $indices.reverse!
        @splice($i, 1)

    removed -> $indices.length    #< number of removed elements
}

#> Returns true if the list contains at least one occurrence of the provided
#| value.
method contains {
    need $what
    -> @any! { -> $what == $_ }
}

#> Finds the first element to satisfy a code.
method first {
    need $code: Code
    for $el in *self {
        if $code($el): -> $el
    }
    -> undefined
}

#> Returns the index of the first occurrence of the given value
method indexOf {
    need $what
    for ($i, $el) in *self {
        if $what == $el: -> $i
    }
    -> undefined
}

#> Returns true if at least one element satisfies a code.
method any {
    need $code: Code
    for $el in *self {
        if $code($el): -> true
    }
    -> false
}

#> Returns true if all elements satisfy a code.
method all {
    need $code: Code
    for $el in *self {
        if !$code($el): -> false
    }
    -> true
}

#> Returns the sum of all elements in the list or `undefined` if the list is
#| empty.
.sum {
    if @empty
        -> undefined
    $c = *self[0]
    for $i in 1 .. @lastIndex {
        $c = $c + *self[$i]
    }
    -> $c
}

#> Returns the sum of all elements in the list or `0` (zero) if the list is
#| empty. Useful for lists of numbers.
.sum0 {
    $c = 0
    for $el in *self {
        $c = $c + $el
    }
    -> $c
}

#> Returns the first element in the list.
.firstItem -> *self[0]

#> Returns the last element in the list.
.lastItem -> *self[@lastIndex]

#> If the list has length one, returns an empty string, otherwise `"s"`
.s {
    if @length == 1
        -> ""
    -> "s"
}

#> Returns an iterator for the list. This allows lists to be used in a for loop.
.iterator -> ListIterator(*self) : Iterator

#> Adding lists together results in an ordered consolidation of the lists.
op + {
    need $rhs: List
    $new = @copy()
    $new.push(items: $rhs)
    -> $new
}

#> Subtracting list B from list A results in a new list containing all elements
#| found in A but not found in B. Example: `[1,2,3,4,5] - [3,5]` -> `[1,2,4]`.
op - {
    need $rhs: List
    $new = @copy()
    for $remove in $rhs:
        $new.removeAll($remove)
    -> $new
}

#> Lists are equal if all the elements are equal and in the same order.
op == {
    need $ehs: List

    # first check if length is same
    if @length != $ehs.length
        -> false

    # check each item
    for ($i, $val) in *self {
        if $ehs[$i] != $val
            -> false
    }

    -> true
}

#> Lists are equal to their numerical length.
op == {
    need $ehs: Num
    -> @length == $ehs
}

#> Lists are greater than numbers smaller than their length.
op > {
    need $rhs: Num
    -> @length > $rhs
}

#> Lists are smaller than numbers greater than their length.
op < {
    need $rhs: Num
    -> @length < $rhs
}

# Iterator methods

.iterator -> *self

method reset {
    @i = -1
}

.more -> @i < (@lastIndex || -1)

.nextElement {
    @i += 1
    -> *self[@i]
}

.nextElements {
    @i += 1
    -> [ @i, *self[@i] ]
}

class List <T?>

#> Represents a list with an event number of elements, treated as pairs.
#| This is similar to a hash with ordered keys.
type Pairs {
    isa *class
    satisfies .length.even
}

#> True if the list is empty.
.empty -> @length == 0

#> Returns a copy of the list by mapping each element to another value based on
#| a transformation code.
.map {
    need $code: Code
    -> gather for $el in *self {
        take $code($el)
    }
}

#> Returns a copy of the list containing only the elements that satisfy a code.
.grep {
    need $code: Code
    -> gather for $el in *self {
        if $code($el): take $el
    }
}

#> Returns a flattened copy of the list.
method flatten {
    $new = []
    for $el in *self {
        if $el.*isa(List)
            $new.push(items: $el.flatten())
        else
            $new.push($el)
    }
    -> $new
}

#> Returns a reversed copy of the list.
method reverse {
    if @empty
        -> *self
    -> gather for $i in @lastIndex..0:
        take *self[$i]
}

#> Copies the list, ignoring all possible occurrences of a specified value.
method withoutAll {
    need $what
    -> @grep! { -> $what != $_ }
    # -> @grep(func { -> $what != $_ })
}

#> Copies the list, ignoring the first occurrence of a specified value.
method without {
    need $what
    var $found
    -> gather for ($i, $el) in *self {
        if !$found && $what == $el {
            $found = true
            next
        }
        take $el
    }
}

#> Removes the first element equal to a specified value.
method remove {
    need $what
    removed -> false
    for ($i, $el) in *self {
        if $what != $el
            next
        @splice($i, 1)
        removed -> true
        last
    }
}

#> Removes all elements equal to a specified value.
method removeAll {
    need $what

    # find the indices at which the value occurs
    $indices = gather for ($i, $el) in *self {
        if $what != $el
            next
        take $i
    }

    # remove
    for $i in $indices.reverse!
        @splice($i, 1)

    removed -> $indices.length    #< number of removed elements
}

#> Returns true if the list contains at least one occurrence of the provided
#| value.
method contains {
    need $what
    -> @any! { -> $what == $_ }
}

#> Finds the first element to satisfy a code.
method first {
    need $code: Code
    for $el in *self {
        if $code($el): -> $el
    }
    -> undefined
}

#> Returns the index of the first occurrence of the given value
method indexOf {
    need $what
    for ($i, $el) in *self {
        if $what == $el: -> $i
    }
    -> undefined
}

#> Returns true if at least one element satisfies a code.
method any {
    need $code: Code
    for $el in *self {
        if $code($el): -> true
    }
    -> false
}

#> Returns true if all elements satisfy a code.
method all {
    need $code: Code
    for $el in *self {
        if !$code($el): -> false
    }
    -> true
}

#> Returns the sum of all elements in the list or `undefined` if the list is
#| empty.
.sum {
    if @empty
        -> undefined
    $c = *self[0]
    for $i in 1 .. @lastIndex {
        $c = $c + *self[$i]
    }
    -> $c
}

#> Returns the sum of all elements in the list or `0` (zero) if the list is
#| empty. Useful for lists of numbers.
.sum0 {
    $c = 0
    for $el in *self {
        $c = $c + $el
    }
    -> $c
}

#> Returns the first element in the list.
.firstItem -> *self[0]

#> Returns the last element in the list.
.lastItem -> *self[@lastIndex]

#> If the list has length one, returns an empty string, otherwise `"s"`
.s {
    if @length == 1
        -> ""
    -> "s"
}

#> Returns an iterator for the list. This allows lists to be used in a for loop.
.iterator -> ListIterator(*self) : Iterator

#> Adding lists together results in an ordered consolidation of the lists.
op + {
    need $rhs: List
    $new = @copy()
    $new.push(items: $rhs)
    -> $new
}

#> Subtracting list B from list A results in a new list containing all elements
#| found in A but not found in B. Example: `[1,2,3,4,5] - [3,5]` -> `[1,2,4]`.
op - {
    need $rhs: List
    $new = @copy()
    for $remove in $rhs:
        $new.removeAll($remove)
    -> $new
}

#> Lists are equal if all the elements are equal and in the same order.
op == {
    need $ehs: List

    # first check if length is same
    if @length != $ehs.length
        -> false

    # check each item
    for ($i, $val) in *self {
        if $ehs[$i] != $val
            -> false
    }

    -> true
}

# Iterator methods

.iterator -> *self

method reset {
    @i = -1
}

.more -> @i < (@lastIndex || -1)

.nextElement {
    @i += 1
    -> *self[@i]
}

.nextElements {
    @i += 1
    -> [ @i, *self[@i] ]
}


Count Pauses.

Count Pauses.

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

internal

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

target

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

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

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

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

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

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

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

external

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

\ UART1
: seremit1  #1 (seremit)  ;
: sertype1	#1 (sertype)  ;
: sercr1	#1 (sercr)  ;
: serkey?1	#1 (serkey?)  ;
: serkey1	#1 (serkey)  ;
create Console1 ' serkey1 , ' serkey?1 , ' seremit1 , ' sertype1 , ' sercr1 ,

\ 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

\ ==============
\ *! 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.
	(seremitfc)
	0<> IF PAUSE THEN
	;

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

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

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

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

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

external

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

\ UART1
: seremit1  #1 (seremit)  ;
: sertype1	#1 (sertype)  ;
: sercr1	#1 (sercr)  ;
: serkey?1	#1 (serkey?)  ;
: serkey1	#1 (serkey)  ;
create Console1 ' serkey1 , ' serkey?1 , ' seremit1 , ' sertype1 , ' sercr1 ,

\ 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


Support the full version of TICKS.

Support the full version of TICKS.

\ Wrappers for SAPI functions, ABI 4.0

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

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

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

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

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

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

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

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

\ CODE (cr)
\ END-CODE

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

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

\ Wrappers for SAPI functions, ABI 4.0

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

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

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

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

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

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

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

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

\ CODE (cr)
\ END-CODE

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

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


Setup the other UART.

Setup the other UART.

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

internal

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

target

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

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

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

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

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

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

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

external

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

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

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

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

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

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

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

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

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

decimal

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

internal

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

target

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

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

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

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

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

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

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

external

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

\ UART1
: seremit1  #1 (seremit)  ;
: sertype1	#1 (sertype)  ;
: sercr1	#1 (sercr)  ;
: serkey?1	#1 (serkey?)  ;
: serkey1	#1 (serkey)  ;
create Console1 ' serkey1 , ' serkey?1 , ' seremit1 , ' sertype1 , ' sercr1 ,

\ 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