more list/number op implementations

more list/number op implementations

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] ]
}

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] ]
}


Update the label for the new name.

Update the label for the new name.

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

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

target

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

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run.  Count these events for debugging purposes.
	DUP >R (seremitfc)
	0<> IF 1 cnt.pause +!
		self tcb.bbstatus @ R> 0 setiocallback drop   stop
		else R> DROP then
	;

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

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

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

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

: (serkey-basic)
	begin pause
	dup (serkey?) until
	(sergetchar)
;

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

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

external

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

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

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

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

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

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

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

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

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

decimal

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

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

target

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

: (seremit)	\ char base --
\ *G Wrapped call that checks for throttling, and if so,
\ calls PAUSE to let another task run.  Count these events for debugging purposes.
	DUP >R (seremitfc)
	0<> IF 1 cnt.pause +!
		self tcb.bbstatus @ R> 0 setiocallback drop   stop
		else R> DROP then
	;

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

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

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

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

: (serkey-basic)
	begin pause
	dup (serkey?) until
	(sergetchar)
;

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

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

external

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

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

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

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

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

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

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

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

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

decimal


midifile: fix mf.seek

midifile: fix mf.seek

reposition-file takes a double word, not a single word

Fixes #128

\ MIDI File Standard Support
\
\ This code allows the sharing of music data between applications.
\
\ Author: Phil Burk
\ Copyright 1989 Phil Burk
\
\ MOD: PLB 6/11/90 Added SWAP to $MF.LOAD.SHAPE
\ MOD: PLB 10/23/90 Added $MF.OPEN.VR
\ MOD: PLB 6/91 Add MIDIFILE1{
\ 00001 PLB 9/5/91 Fix MIDIFILE1{ by c/i/j/
\ 00002 PLB 3/17/92 Changed MF.WRITE.REL.SHAPE to make notes legato
\       for notation programs.  Add $SAVE.REL.SHAPE and $..ABS..

ANEW TASK-MIDIFILE
decimal

\ Variable Length Number Conversion
variable VLN-PAD  ( accumulator for variable length number )
variable VLN-COUNT  ( number of bytes )

: BYTE>VLN  ( byte -- , add byte to VLN buffer )
    vln-count @ 0>
    IF $ 80 or     ( set continuation bit )
    THEN
    vln-pad 4+ vln-count @ 1+ dup vln-count !
    - c!
;

: NUMBER->VLN  ( N -- address count , convert )
    dup $ 0FFFFFFF >
    IF ." NUMBER->VL - Number too big for MIDI File! = "
       dup .hex cr
       $ 0FFFFFFF and
    THEN
    dup 0<
    IF ." NUMBER->VL - Negative length or time! = "
       dup .hex cr
       drop 0
    THEN
    vln-count off
    BEGIN dup $ 7F and byte>vln
        -7 shift dup 0=
    UNTIL drop
    vln-pad 4+ vln-count @ dup>r - r>
;

: VLN.CLEAR ( -- , clear for read )
    vln-count off vln-pad off
;

: VLN.ACCUM  ( byte -- accumulate another byte )
    $ 7F and
    vln-pad @ 7 shift or vln-pad !
;

\ -------------------------------------------------
variable MF-BYTESLEFT
variable MF-EVENT-TIME
variable MF-#DATA

: CHKID ( <chkid> <name> -- , define chkid )
    32 lword count drop be@ constant
;

chkid MThd 'MThd'
chkid MTrk 'MTrk'

variable mf-FILEID
16 constant MF_PAD_SIZE
variable mf-PAD mf_pad_size allot

DEFER MF.PROCESS.TRACK   ( size track# -- )
DEFER MF.ERROR

' abort is mf.error

: .CHKID ( 'chkid' -- , print chunk id )
    pad be! pad 4 type
;

: $MF.OPEN  ( $filename -- )
    dup c@ 0=
    IF drop ." $MF.OPEN - No filename given!" cr mf.error
    THEN
    dup count  r/o bin open-file
    IF drop ." Couldn't open file: " $type cr mf.error
    THEN
    mf-fileid !
    drop
;

: $MF.CREATE  ( $filename -- , create new file )
    dup c@ 0=
    IF drop ." $MF.OPEN - No filename given!" cr mf.error
    THEN
    dup count w/o bin create-file
    IF drop ." Couldn't create file: " $type cr mf.error
    THEN
    mf-fileid !
    drop
;
: MF.SET.FILE  ( fileid -- )
    mf-fileid !
;

: MF.READ ( addr #bytes -- #bytes , read from open mf file)
    dup negate mf-bytesleft +!
    mf-fileid @ read-file abort" Could not read MIDI file."
;

: MF.READ.CHKID  ( -- size chkid )
    dup>r mf-pad 8 mf.read
    8 -
    IF ." Truncated chunk " r@ .chkid cr mf.error
    THEN
    rdrop
    mf-pad cell+ be@
    mf-pad be@
;

: MF.WRITE ( addr #bytes -- #bytes , write to open mf file)
    dup>r mf-fileid @ write-file abort" Could not write MIDI file."
    r>
;

: MF.WRITE? ( addr #bytes -- , write to open mf file or mf.ERROR)
    mf-fileid @ write-file abort" Could not write MIDI file."
;

: MF.READ.BYTE ( -- byte )
    mf-pad 1 mf.read 1-
    IF ." MF.READ.BYTE - Unexpected EOF!" cr mf.error
    THEN
    mf-pad c@
;

: MF.WRITE.BYTE ( byte -- )
    mf-pad c! mf-pad 1 mf.write?
;

: MF.WRITE.WORD ( 16word -- )
    mf-pad w! mf-pad 2 mf.write?
;

: MF.READ.WORD ( -- 16word )
    mf-pad 2 mf.read 2-
    IF ." MF.READ.WORD - Unexpected EOF!" cr mf.error
    THEN
    mf-pad w@
;

: MF.WRITE.CHKID  ( size chkid -- , write chunk header )
    mf-pad be!
    mf-pad cell+ be!
    mf-pad 8 mf.write?
;

: MF.WRITE.CHUNK  ( address size chkid -- , write complete chunk )
    over >r mf.write.chkid
    r> mf.write?
;

: MF.READ.TYPE  ( -- typeid )
    mf-pad 4 mf.read
    4 -
    IF ." Truncated type!" cr mf.error
    THEN
    mf-pad be@
;

: MF.WHERE ( -- current_pos , in file )
    mf-fileid @ file-position abort" file-position failed"
    d>s   \ file-position returns a double word
;

: MF.SEEK ( position -- , in file )
    s>d   \ reposition-file takes a double word
    mf-fileid @ reposition-file abort" reposition-file failed"
;

: MF.SKIP  ( n -- , skip n bytes in file )
    dup negate mf-bytesleft +!
    mf.where + mf.seek
;

: MF.CLOSE
    mf-fileid @ ?dup
    IF  close-file abort" close-file failed"
        0 mf-fileid !
    THEN
;

variable MF-NTRKS    \ number of tracks in file
variable MF-FORMAT   \ file format = 0 | 1 | 2
variable MF-DIVISION \ packed division

: MF.PROCESS.HEADER  ( size -- )
    dup mf_pad_size >
    IF ." MF.PROCESS.HEADER - Bad Header Size = "
       dup . cr mf.error
    THEN
    mf-pad swap mf.read drop
    mf-pad bew@ mf-format w!
    mf-pad 2+ bew@ mf-ntrks !
    mf-pad 4+ bew@ mf-division !
;

: MF.SCAN.HEADER ( -- , read header )
    mf.read.chkid  ( -- size chkid)
    'MThd' =
    IF mf.process.header
    ELSE ." MF.SCAN - Headerless MIDIFile!" cr mf.error
    THEN
;

: MF.SCAN.TRACKS ( -- , read tracks )
\ This word leaves the file position just after the chunk data.
    mf-ntrks @ 0
    DO mf.read.chkid 'MTrk' =
       IF dup mf.where + >r
          i mf.process.track
          r> mf.seek ( move past chunk)
       ELSE ." MF.SCAN - Unexpected CHKID!" cr mf.error
       THEN
    LOOP
;

: MF.SCAN ( -- , read header then tracks)
    mf.scan.header
    mf.scan.tracks
;

: MF.VALIDATE ( -- ok? , make sure open file has header chunk )
    mf.where
    0 mf.seek
    mf.read.type 'MThd' =
    swap mf.seek
;

: (MF.DOFILE) ( -- ,process current file )
    mf.validate
    IF  mf.scan
    ELSE ."  Not a MIDIFile!" cr
        mf.close mf.error
    THEN
    mf.close
;

: $MF.DOFILE ( $filename -- , process file using deferred words)
    $mf.open (mf.dofile)
;

: MF.DOFILE ( <filename> -- )
    fileword $mf.dofile
;

: MF.READ.VLN ( -- vln , read vln from file )
    vln.clear
    BEGIN mf.read.byte dup $ 80 and
    WHILE vln.accum
    REPEAT vln.accum
    vln-pad @
;

defer MF.PROCESS.META  ( size metaID -- , process Meta event )
defer MF.PROCESS.SYSEX
defer MF.PROCESS.ESCAPE

variable MF-SEQUENCE#
variable MF-CHANNEL
: MF.LOOK.TEXT ( size metaID -- , read and show text )
    >newline ." MetaEvent = " . cr
    pad swap mf.read
    pad swap type cr
;

: MF.HANDLE.META  ( size MetaID -- default Meta event handler )
    dup $ 01 $ 0f within?
    IF mf.look.text
    ELSE CASE
        $ 00 OF drop mf.read.word mf-sequence# ! ENDOF
        $ 20 OF drop mf.read.byte 1+ mf-channel ! ENDOF
          ." MetaEvent = " dup . cr
          swap mf.skip  ( skip over other event types )
        ENDCASE
    THEN
;

' mf.handle.meta is MF.PROCESS.META
' mf.skip is MF.PROCESS.SYSEX
' mf.skip is MF.PROCESS.ESCAPE

: MF.PARSE.EVENT ( -- , parse MIDI event )
    mf.read.byte dup $ 80 and  ( is it a command or running status data )
    IF CASE
        $ FF OF mf.read.byte  ( get type )
                mf.read.vln ( get size ) swap mf.process.meta ENDOF
        $ F0 OF ." F0 byte" cr mf.read.vln mf.process.sysex ENDOF
        $ F7 OF ." F7 byte" cr mf.read.vln mf.process.escape ENDOF
\ Regular command.
    dup mp.#bytes mf-#data !
        dup mp.handle.command
        mf-#data @ 0
        DO mf.read.byte mp.handle.data
        LOOP
       ENDCASE
    ELSE
        mp.handle.data  ( call MIDI parser with byte read )
        mf-#data @ 1- 0 max 0
        DO mf.read.byte mp.handle.data
        LOOP
    THEN
;

: MF.PARSE.TRACK  ( size track# -- )
    drop mf-bytesleft !
    0 mf-event-time !
    BEGIN mf.read.vln mf-event-time +!
          mf.parse.event
          mf-bytesleft @ 1 <
    UNTIL
;

\ Some Track Handlers
: MF.PRINT.NOTEON ( note velocity -- )
          ?pause
    mf-event-time @ 4 .r ." , "
    ." ON  N,V = " swap . . cr
;
: MF.PRINT.NOTEOFF ( note velocity -- )
          ?pause
    mf-event-time @ 4 .r ." , "
    ." OFF N,V = " swap . . cr
;

: MF.PRINT.TRACK  ( size track# -- )
    2dup
    >newline dup 0=
    IF ." MIDIFile Format = " mf-format @ . cr
       ."        Division = $" mf-division @ dup .hex . cr
    THEN
    ." Track# " . ."  is " . ."  bytes." cr
    'c mf.print.noteon mp-on-vector !
    'c mf.print.noteoff mp-off-vector !
    mf.parse.track
    mp.reset
;

' mf.print.track is mf.process.track

: MF.CHECK ( <filename> -- , print chunks )
    what's mf.process.track
    ' mf.print.track is mf.process.track
    mf.dofile
    is mf.process.track
;

\ Track Handler that loads a shape -----------------------
variable MF-TRACK-CHOSEN
ob.shape MF-SHAPE

: MF.LOAD.NOTEON ( note velocity -- )
    mf-shape ensure.room
    mf-event-time @ -rot add: mf-shape
;

: MF.LOAD.NOTEOFF ( note velocity -- )
    mf-shape ensure.room
    drop mf-event-time @ swap 0 add: mf-shape
;

: MF.LOAD.TRACK ( size track# -- )
    max.elements: mf-shape 0=
    IF 64 3 new: mf-shape
    ELSE clear: mf-shape
    THEN
    'c mf.load.noteon mp-on-vector !
    'c mf.load.noteoff mp-off-vector !
    mf.parse.track
;

: MF.PICK.TRACK  ( size track# -- )
    dup mf-track-chosen @ =
    IF mf.load.track
    ELSE 2drop
    THEN
;

: $MF.LOAD.SHAPE  ( track# $filename -- , load track into mf-shape )
    swap mf-track-chosen !
    what's mf.process.track  SWAP  ( -- oldcfa $filename )
    'c mf.pick.track is mf.process.track
    $mf.dofile
    is mf.process.track
;

: MF.LOAD.SHAPE  ( track# <filename> -- , load track into mf-shape )
    fileword $mf.load.shape
;

: LOAD.ABS.SHAPE  ( shape <filename> -- )
    0 mf.load.shape
    clone: mf-shape
    free: mf-shape
;

\ -------------------------------------------------

\ Tools for writing a MIDIFile.
: MF.WRITE.HEADER  ( format ntrks division -- )
    6 'MThd' mf.write.chkid
    mf-pad 4+ bew!  ( division )
    over 0=
    IF drop 1  ( force NTRKS to 1 for format zero )
    THEN
    mf-pad 2+ bew!  ( ntrks )
    mf-pad    bew!  ( format )
    mf-pad 6 mf.write?
;

: MF.BEGIN.TRACK  ( -- curpos , write track start )
    0 'MTrk' mf.write.chkid
    mf.where
    0 mf-event-time !
;

: MF.WRITE.VLN ( n -- , write variable length quantity )
    number->vln mf.write?
;

: MF.WRITE.TIME ( time -- , write time as vln delta )
    dup mf-event-time @ - mf.write.vln
    mf-event-time !
;

: MF.WRITE.EVENT  ( addr count time -- , write MIDI event )
\ This might be called from custom MIDI.FLUSH
    mf.write.time
    mf.write?
;

variable MF-EVENT-PAD

: MF.WRITE.META  ( addr count event-type -- )
    mf-event-time @ mf.write.time
    $ FF mf.write.byte
    mf.write.byte  ( event type )
    dup mf.write.vln  ( len )
    mf.write?
;

: MF.WRITE.SYSEX  ( addr count -- )
    mf-event-time @ mf.write.time
    $ F0 mf.write.byte
    dup mf.write.vln  ( len )
    mf.write?
;

: MF.WRITE.ESCAPE  ( addr count -- )
    mf-event-time @ mf.write.time
    $ F7 mf.write.byte
    dup mf.write.vln  ( len )
    mf.write?
;

: MF.WRITE.SEQ#  ( seq#  -- )
    mf-event-pad w!
    mf-event-pad 2 0 mf.write.meta
;

: MF.WRITE.END  ( -- , write end of track )
    mf-event-pad 0
    $ 2F mf.write.meta
;

: MF.END.TRACK  ( startpos -- , write length to track beginning )
    mf.where dup>r  ( so we can return )
    over -   ( -- start #bytes )
    swap cell- mf.seek
    mf-pad be! mf-pad 4 mf.write?
    r> mf.seek
;

: MF.CVM+2D ( time d1 d2 cvm -- )
    mf-event-pad c!
    mf-event-pad 2+ c!
    mf-event-pad 1+ c!
    mf-event-pad 3 rot mf.write.event
;

: MF.WRITE.NOTEON ( time note velocity -- )
    $ 90 mf.cvm+2d
;

: MF.WRITE.NOTEOFF ( time note velocity -- )
    $ 80 mf.cvm+2d
;

: $MF.BEGIN.FORMAT0  ( $name -- pos , begin format0 file )
    $mf.create
    0 1 ticks/beat @ mf.write.header
    mf.begin.track  ( startpos )
;

: MF.BEGIN.FORMAT0  ( <name> -- pos , begin format0 file )
    fileword $mf.begin.format0
;

: MF.END.FORMAT0  ( pos -- , end format0 file )
    mf.write.end
    mf.end.track
    mf.close
;

: MF.WRITE.ABS.SHAPE { shape -- , assume shape Nx3+ absolute time }
\ Assume separate note on/off in shape
    shape reset: []
    shape many: [] 0
    DO i 0 shape ed.at: [] ( -- time )
       i 1 shape ed.at: [] ( -- time note )
       i 2 shape ed.at: [] ( -- time note vel )
       dup 0=
       IF mf.write.noteoff
       ELSE mf.write.noteon
       THEN
    LOOP
;

variable MF-SHAPE-TIME

: MF.WRITE.REL.SHAPE { shape | note vel -- , assume shape Nx3 relative time }
    0 mf-shape-time !
    shape reset: []
    shape many: [] 0
    DO
        i 1 shape ed.at: [] -> note ( -- time note )
        i 2 shape ed.at: [] -> vel ( -- time note vel )
        mf-shape-time @ note vel mf.write.noteon
\
\ add to shape time so OFF occurs right before next notes ON 00002
        i 0 shape ed.at: [] ( -- reltime )
        mf-shape-time @ +
        dup mf-shape-time !
        note vel mf.write.noteoff
    LOOP
;

: $SAVE.REL.SHAPE  ( shape $filename -- , complete file output )
\ This word writes out a relative time, 1 event/note shape
\ as note on,off
    $mf.begin.format0
    swap mf.write.rel.shape
    mf.end.format0
;

: $SAVE.ABS.SHAPE  ( shape $filename -- , complete file output )
\ This word writes out a shape as note on,off
    $mf.begin.format0
    swap mf.write.abs.shape
    mf.end.format0
;

: SAVE.REL.SHAPE  ( shape <name> -- , complete file output )
    fileword $save.rel.shape
;

: SAVE.ABS.SHAPE  ( shape <name> -- , complete file output )
    fileword $save.abs.shape
;

: MF.WRITE.TIMESIG  ( nn dd cc bb -- )
    mf-event-pad 3 + c!  ( time sig, numerator )
    mf-event-pad 2+  c!  ( denom log2 )
    mf-event-pad 1+  c!  ( MIDI clocks/metronome click )
    mf-event-pad     c!  ( 32nd notes in 24 clocks )
    mf-event-pad 4 $ 58 mf.write.meta
;

: MF.WRITE.TEMPO  ( mics/beat -- )
    mf-event-pad !
    mf-event-pad 1+ 3 $ 51 mf.write.meta
;

\ Capture all MIDI output to a Format0 file
variable MF-START-POS
variable MF-FIRST-WRITE

: (MF.CAPTURED>FILE0)  ( -- write captured MIDI to file format 0)
    0 0 ed.at: captured-midi mf-event-time !
    many: captured-midi 0
    DO i get: captured-midi midi.unpack
       rot mf.write.event
    LOOP
    mf-start-pos @ mf.end.format0
;

: }MIDIFILE0  ( -- )
    if-capturing @
    IF  (mf.captured>file0)
        }capture
    THEN
;

: $CAPTURED>MIDIFILE0  ( $filename -- )
    $mf.begin.format0 mf-start-pos !  ( use filename while still valid )
    (mf.captured>file0)
;

: $MIDIFILE0{  ( $filename -- , start capturing MIDI data )
    }midifile0
    $mf.begin.format0 mf-start-pos !  ( use filename while still valid )
    capture{
;

: MIDIFILE0{ ( <name> -- )
    fileword $midifile0{
;

CREATE MF-COUNT-CAPS 16 allot

: CAP.GET.CHAN  ( status-byte -- channel# )
    $ 0F and 1+
;

: CAP.COUNT.CHANS ( -- #channels , count captured track/channels )
    16 0
    DO 0 i mf-count-caps + c!
    LOOP
\
    many: captured-midi 0
    DO i get: captured-midi midi.unpack drop c@
        cap.get.chan 1-
        nip
        mf-count-caps + 1 swap c!  ( set flag in array )
    LOOP
\
    0
    16 0
    DO i mf-count-caps + c@ +
    LOOP
;

: (MF.CAPTURED>FILE1)  ( -- , write tracks with data to metafile )
    cap.count.chans ( #chans )
    \ write a track zero that should contain tempo maps
    1+ \ for track zero
    mf.begin.track  ( -- pos )
    mf.write.end
    mf.end.track
    \ Write each track with sequence number
    16 0
    DO i mf-count-caps + c@
        IF
            mf.begin.track  ( -- pos )
            0 0 ed.at: captured-midi mf-event-time !
            i 1+ mf.write.seq#
            many: captured-midi 0
            DO
                i get: captured-midi midi.unpack
                over c@ cap.get.chan 1- j  = \ 00001
                IF
                    ( time addr count -- )
                    rot mf.write.event
                ELSE 2drop drop
                THEN
            LOOP
            mf.write.end
            mf.end.track
       THEN
    LOOP
    0 mf.seek
    1 swap ticks/beat @ mf.write.header
    mf.close
;

: }MIDIFILE1  ( -- )
    if-capturing @
    IF  (mf.captured>file1)
        }capture
    THEN
;

: $CAPTURED>MIDIFILE1  ( $filename -- )
    $mf.create
    1 1 ticks/beat @ mf.write.header
    (mf.captured>file1)
;

: $MIDIFILE1{  ( $filename -- , start capturing MIDI data )
    }midifile1
     $mf.create
    1 1 ticks/beat @ mf.write.header
    capture{
;

: MIDIFILE1{ ( <name> -- )
    fileword $midifile1{
;

\ set aliases to format 0 for compatibility with old code
: MIDIFILE{ midifile0{ ;
: $MIDIFILE{ $midifile0{ ;
: }MIDIFILE }midifile0 ;

if.forgotten }midifile0

: tmf
    " testzz5.mid" $midifile0{
    rnow 55 60 midi.noteon
    200 vtime+!
    55 0 midi.noteoff
    }midifile0
;

\ MIDI File Standard Support
\
\ This code allows the sharing of music data between applications.
\
\ Author: Phil Burk
\ Copyright 1989 Phil Burk
\
\ MOD: PLB 6/11/90 Added SWAP to $MF.LOAD.SHAPE
\ MOD: PLB 10/23/90 Added $MF.OPEN.VR
\ MOD: PLB 6/91 Add MIDIFILE1{
\ 00001 PLB 9/5/91 Fix MIDIFILE1{ by c/i/j/
\ 00002 PLB 3/17/92 Changed MF.WRITE.REL.SHAPE to make notes legato
\       for notation programs.  Add $SAVE.REL.SHAPE and $..ABS..

ANEW TASK-MIDIFILE
decimal

\ Variable Length Number Conversion
variable VLN-PAD  ( accumulator for variable length number )
variable VLN-COUNT  ( number of bytes )

: BYTE>VLN  ( byte -- , add byte to VLN buffer )
    vln-count @ 0>
    IF $ 80 or     ( set continuation bit )
    THEN
    vln-pad 4+ vln-count @ 1+ dup vln-count !
    - c!
;

: NUMBER->VLN  ( N -- address count , convert )
    dup $ 0FFFFFFF >
    IF ." NUMBER->VL - Number too big for MIDI File! = "
       dup .hex cr
       $ 0FFFFFFF and
    THEN
    dup 0<
    IF ." NUMBER->VL - Negative length or time! = "
       dup .hex cr
       drop 0
    THEN
    vln-count off
    BEGIN dup $ 7F and byte>vln
        -7 shift dup 0=
    UNTIL drop
    vln-pad 4+ vln-count @ dup>r - r>
;

: VLN.CLEAR ( -- , clear for read )
    vln-count off vln-pad off
;

: VLN.ACCUM  ( byte -- accumulate another byte )
    $ 7F and
    vln-pad @ 7 shift or vln-pad !
;

\ -------------------------------------------------
variable MF-BYTESLEFT
variable MF-EVENT-TIME
variable MF-#DATA

: CHKID ( <chkid> <name> -- , define chkid )
    32 lword count drop be@ constant
;

chkid MThd 'MThd'
chkid MTrk 'MTrk'

variable mf-FILEID
16 constant MF_PAD_SIZE
variable mf-PAD mf_pad_size allot

DEFER MF.PROCESS.TRACK   ( size track# -- )
DEFER MF.ERROR

' abort is mf.error

: .CHKID ( 'chkid' -- , print chunk id )
    pad be! pad 4 type
;

: $MF.OPEN  ( $filename -- )
    dup c@ 0=
    IF drop ." $MF.OPEN - No filename given!" cr mf.error
    THEN
    dup count  r/o bin open-file
    IF drop ." Couldn't open file: " $type cr mf.error
    THEN
    mf-fileid !
    drop
;

: $MF.CREATE  ( $filename -- , create new file )
    dup c@ 0=
    IF drop ." $MF.OPEN - No filename given!" cr mf.error
    THEN
    dup count w/o bin create-file
    IF drop ." Couldn't create file: " $type cr mf.error
    THEN
    mf-fileid !
    drop
;
: MF.SET.FILE  ( fileid -- )
    mf-fileid !
;

: MF.READ ( addr #bytes -- #bytes , read from open mf file)
    dup negate mf-bytesleft +!
    mf-fileid @ read-file abort" Could not read MIDI file."
;

: MF.READ.CHKID  ( -- size chkid )
    dup>r mf-pad 8 mf.read
    8 -
    IF ." Truncated chunk " r@ .chkid cr mf.error
    THEN
    rdrop
    mf-pad cell+ be@
    mf-pad be@
;

: MF.WRITE ( addr #bytes -- #bytes , write to open mf file)
    dup>r mf-fileid @ write-file abort" Could not write MIDI file."
    r>
;

: MF.WRITE? ( addr #bytes -- , write to open mf file or mf.ERROR)
    mf-fileid @ write-file abort" Could not write MIDI file."
;

: MF.READ.BYTE ( -- byte )
    mf-pad 1 mf.read 1-
    IF ." MF.READ.BYTE - Unexpected EOF!" cr mf.error
    THEN
    mf-pad c@
;

: MF.WRITE.BYTE ( byte -- )
    mf-pad c! mf-pad 1 mf.write?
;

: MF.WRITE.WORD ( 16word -- )
    mf-pad w! mf-pad 2 mf.write?
;

: MF.READ.WORD ( -- 16word )
    mf-pad 2 mf.read 2-
    IF ." MF.READ.WORD - Unexpected EOF!" cr mf.error
    THEN
    mf-pad w@
;

: MF.WRITE.CHKID  ( size chkid -- , write chunk header )
    mf-pad be!
    mf-pad cell+ be!
    mf-pad 8 mf.write?
;

: MF.WRITE.CHUNK  ( address size chkid -- , write complete chunk )
    over >r mf.write.chkid
    r> mf.write?
;

: MF.READ.TYPE  ( -- typeid )
    mf-pad 4 mf.read
    4 -
    IF ." Truncated type!" cr mf.error
    THEN
    mf-pad be@
;

: MF.WHERE ( -- current_pos , in file )
    mf-fileid @ file-position abort" file-position failed"
;

: MF.SEEK ( position -- , in file )
    mf-fileid @ reposition-file abort" reposition-file failed"
;

: MF.SKIP  ( n -- , skip n bytes in file )
    dup negate mf-bytesleft +!
    mf.where + mf.seek
;

: MF.CLOSE
    mf-fileid @ ?dup
    IF  close-file abort" close-file failed"
        0 mf-fileid !
    THEN
;

variable MF-NTRKS    \ number of tracks in file
variable MF-FORMAT   \ file format = 0 | 1 | 2
variable MF-DIVISION \ packed division

: MF.PROCESS.HEADER  ( size -- )
    dup mf_pad_size >
    IF ." MF.PROCESS.HEADER - Bad Header Size = "
       dup . cr mf.error
    THEN
    mf-pad swap mf.read drop
    mf-pad bew@ mf-format w!
    mf-pad 2+ bew@ mf-ntrks !
    mf-pad 4+ bew@ mf-division !
;

: MF.SCAN.HEADER ( -- , read header )
    mf.read.chkid  ( -- size chkid)
    'MThd' =
    IF mf.process.header
    ELSE ." MF.SCAN - Headerless MIDIFile!" cr mf.error
    THEN
;

: MF.SCAN.TRACKS ( -- , read tracks )
\ This word leaves the file position just after the chunk data.
    mf-ntrks @ 0
    DO mf.read.chkid 'MTrk' =
       IF dup mf.where + >r
          i mf.process.track
          r> mf.seek ( move past chunk)
       ELSE ." MF.SCAN - Unexpected CHKID!" cr mf.error
       THEN
    LOOP
;

: MF.SCAN ( -- , read header then tracks)
    mf.scan.header
    mf.scan.tracks
;

: MF.VALIDATE ( -- ok? , make sure open file has header chunk )
    mf.where
    0 mf.seek
    mf.read.type 'MThd' =
    swap mf.seek
;

: (MF.DOFILE) ( -- ,process current file )
    mf.validate
    IF  mf.scan
    ELSE ."  Not a MIDIFile!" cr
        mf.close mf.error
    THEN
    mf.close
;

: $MF.DOFILE ( $filename -- , process file using deferred words)
    $mf.open (mf.dofile)
;

: MF.DOFILE ( <filename> -- )
    fileword $mf.dofile
;

: MF.READ.VLN ( -- vln , read vln from file )
    vln.clear
    BEGIN mf.read.byte dup $ 80 and
    WHILE vln.accum
    REPEAT vln.accum
    vln-pad @
;

defer MF.PROCESS.META  ( size metaID -- , process Meta event )
defer MF.PROCESS.SYSEX
defer MF.PROCESS.ESCAPE

variable MF-SEQUENCE#
variable MF-CHANNEL
: MF.LOOK.TEXT ( size metaID -- , read and show text )
    >newline ." MetaEvent = " . cr
    pad swap mf.read
    pad swap type cr
;

: MF.HANDLE.META  ( size MetaID -- default Meta event handler )
    dup $ 01 $ 0f within?
    IF mf.look.text
    ELSE CASE
        $ 00 OF drop mf.read.word mf-sequence# ! ENDOF
        $ 20 OF drop mf.read.byte 1+ mf-channel ! ENDOF
          ." MetaEvent = " dup . cr
          swap mf.skip  ( skip over other event types )
        ENDCASE
    THEN
;

' mf.handle.meta is MF.PROCESS.META
' mf.skip is MF.PROCESS.SYSEX
' mf.skip is MF.PROCESS.ESCAPE

: MF.PARSE.EVENT ( -- , parse MIDI event )
    mf.read.byte dup $ 80 and  ( is it a command or running status data )
    IF CASE
        $ FF OF mf.read.byte  ( get type )
                mf.read.vln ( get size ) swap mf.process.meta ENDOF
        $ F0 OF ." F0 byte" cr mf.read.vln mf.process.sysex ENDOF
        $ F7 OF ." F7 byte" cr mf.read.vln mf.process.escape ENDOF
\ Regular command.
    dup mp.#bytes mf-#data !
        dup mp.handle.command
        mf-#data @ 0
        DO mf.read.byte mp.handle.data
        LOOP
       ENDCASE
    ELSE
        mp.handle.data  ( call MIDI parser with byte read )
        mf-#data @ 1- 0 max 0
        DO mf.read.byte mp.handle.data
        LOOP
    THEN
;

: MF.PARSE.TRACK  ( size track# -- )
    drop mf-bytesleft !
    0 mf-event-time !
    BEGIN mf.read.vln mf-event-time +!
          mf.parse.event
          mf-bytesleft @ 1 <
    UNTIL
;

\ Some Track Handlers
: MF.PRINT.NOTEON ( note velocity -- )
          ?pause
    mf-event-time @ 4 .r ." , "
    ." ON  N,V = " swap . . cr
;
: MF.PRINT.NOTEOFF ( note velocity -- )
          ?pause
    mf-event-time @ 4 .r ." , "
    ." OFF N,V = " swap . . cr
;

: MF.PRINT.TRACK  ( size track# -- )
    2dup
    >newline dup 0=
    IF ." MIDIFile Format = " mf-format @ . cr
       ."        Division = $" mf-division @ dup .hex . cr
    THEN
    ." Track# " . ."  is " . ."  bytes." cr
    'c mf.print.noteon mp-on-vector !
    'c mf.print.noteoff mp-off-vector !
    mf.parse.track
    mp.reset
;

' mf.print.track is mf.process.track

: MF.CHECK ( <filename> -- , print chunks )
    what's mf.process.track
    ' mf.print.track is mf.process.track
    mf.dofile
    is mf.process.track
;

\ Track Handler that loads a shape -----------------------
variable MF-TRACK-CHOSEN
ob.shape MF-SHAPE

: MF.LOAD.NOTEON ( note velocity -- )
    mf-shape ensure.room
    mf-event-time @ -rot add: mf-shape
;

: MF.LOAD.NOTEOFF ( note velocity -- )
    mf-shape ensure.room
    drop mf-event-time @ swap 0 add: mf-shape
;

: MF.LOAD.TRACK ( size track# -- )
    max.elements: mf-shape 0=
    IF 64 3 new: mf-shape
    ELSE clear: mf-shape
    THEN
    'c mf.load.noteon mp-on-vector !
    'c mf.load.noteoff mp-off-vector !
    mf.parse.track
;

: MF.PICK.TRACK  ( size track# -- )
    dup mf-track-chosen @ =
    IF mf.load.track
    ELSE 2drop
    THEN
;

: $MF.LOAD.SHAPE  ( track# $filename -- , load track into mf-shape )
    swap mf-track-chosen !
    what's mf.process.track  SWAP  ( -- oldcfa $filename )
    'c mf.pick.track is mf.process.track
    $mf.dofile
    is mf.process.track
;

: MF.LOAD.SHAPE  ( track# <filename> -- , load track into mf-shape )
    fileword $mf.load.shape
;

: LOAD.ABS.SHAPE  ( shape <filename> -- )
    0 mf.load.shape
    clone: mf-shape
    free: mf-shape
;

\ -------------------------------------------------

\ Tools for writing a MIDIFile.
: MF.WRITE.HEADER  ( format ntrks division -- )
    6 'MThd' mf.write.chkid
    mf-pad 4+ bew!  ( division )
    over 0=
    IF drop 1  ( force NTRKS to 1 for format zero )
    THEN
    mf-pad 2+ bew!  ( ntrks )
    mf-pad    bew!  ( format )
    mf-pad 6 mf.write?
;

: MF.BEGIN.TRACK  ( -- curpos , write track start )
    0 'MTrk' mf.write.chkid
    mf.where
    0 mf-event-time !
;

: MF.WRITE.VLN ( n -- , write variable length quantity )
    number->vln mf.write?
;

: MF.WRITE.TIME ( time -- , write time as vln delta )
    dup mf-event-time @ - mf.write.vln
    mf-event-time !
;

: MF.WRITE.EVENT  ( addr count time -- , write MIDI event )
\ This might be called from custom MIDI.FLUSH
    mf.write.time
    mf.write?
;

variable MF-EVENT-PAD

: MF.WRITE.META  ( addr count event-type -- )
    mf-event-time @ mf.write.time
    $ FF mf.write.byte
    mf.write.byte  ( event type )
    dup mf.write.vln  ( len )
    mf.write?
;

: MF.WRITE.SYSEX  ( addr count -- )
    mf-event-time @ mf.write.time
    $ F0 mf.write.byte
    dup mf.write.vln  ( len )
    mf.write?
;

: MF.WRITE.ESCAPE  ( addr count -- )
    mf-event-time @ mf.write.time
    $ F7 mf.write.byte
    dup mf.write.vln  ( len )
    mf.write?
;

: MF.WRITE.SEQ#  ( seq#  -- )
    mf-event-pad w!
    mf-event-pad 2 0 mf.write.meta
;

: MF.WRITE.END  ( -- , write end of track )
    mf-event-pad 0
    $ 2F mf.write.meta
;

: MF.END.TRACK  ( startpos -- , write length to track beginning )
    mf.where dup>r  ( so we can return )
    over -   ( -- start #bytes )
    swap cell- mf.seek
    mf-pad be! mf-pad 4 mf.write?
    r> mf.seek
;

: MF.CVM+2D ( time d1 d2 cvm -- )
    mf-event-pad c!
    mf-event-pad 2+ c!
    mf-event-pad 1+ c!
    mf-event-pad 3 rot mf.write.event
;

: MF.WRITE.NOTEON ( time note velocity -- )
    $ 90 mf.cvm+2d
;

: MF.WRITE.NOTEOFF ( time note velocity -- )
    $ 80 mf.cvm+2d
;

: $MF.BEGIN.FORMAT0  ( $name -- pos , begin format0 file )
    $mf.create
    0 1 ticks/beat @ mf.write.header
    mf.begin.track  ( startpos )
;

: MF.BEGIN.FORMAT0  ( <name> -- pos , begin format0 file )
    fileword $mf.begin.format0
;

: MF.END.FORMAT0  ( pos -- , end format0 file )
    mf.write.end
    mf.end.track
    mf.close
;

: MF.WRITE.ABS.SHAPE { shape -- , assume shape Nx3+ absolute time }
\ Assume separate note on/off in shape
    shape reset: []
    shape many: [] 0
    DO i 0 shape ed.at: [] ( -- time )
       i 1 shape ed.at: [] ( -- time note )
       i 2 shape ed.at: [] ( -- time note vel )
       dup 0=
       IF mf.write.noteoff
       ELSE mf.write.noteon
       THEN
    LOOP
;

variable MF-SHAPE-TIME

: MF.WRITE.REL.SHAPE { shape | note vel -- , assume shape Nx3 relative time }
    0 mf-shape-time !
    shape reset: []
    shape many: [] 0
    DO
        i 1 shape ed.at: [] -> note ( -- time note )
        i 2 shape ed.at: [] -> vel ( -- time note vel )
        mf-shape-time @ note vel mf.write.noteon
\
\ add to shape time so OFF occurs right before next notes ON 00002
        i 0 shape ed.at: [] ( -- reltime )
        mf-shape-time @ +
        dup mf-shape-time !
        note vel mf.write.noteoff
    LOOP
;

: $SAVE.REL.SHAPE  ( shape $filename -- , complete file output )
\ This word writes out a relative time, 1 event/note shape
\ as note on,off
    $mf.begin.format0
    swap mf.write.rel.shape
    mf.end.format0
;

: $SAVE.ABS.SHAPE  ( shape $filename -- , complete file output )
\ This word writes out a shape as note on,off
    $mf.begin.format0
    swap mf.write.abs.shape
    mf.end.format0
;

: SAVE.REL.SHAPE  ( shape <name> -- , complete file output )
    fileword $save.rel.shape
;

: SAVE.ABS.SHAPE  ( shape <name> -- , complete file output )
    fileword $save.abs.shape
;

: MF.WRITE.TIMESIG  ( nn dd cc bb -- )
    mf-event-pad 3 + c!  ( time sig, numerator )
    mf-event-pad 2+  c!  ( denom log2 )
    mf-event-pad 1+  c!  ( MIDI clocks/metronome click )
    mf-event-pad     c!  ( 32nd notes in 24 clocks )
    mf-event-pad 4 $ 58 mf.write.meta
;

: MF.WRITE.TEMPO  ( mics/beat -- )
    mf-event-pad !
    mf-event-pad 1+ 3 $ 51 mf.write.meta
;

\ Capture all MIDI output to a Format0 file
variable MF-START-POS
variable MF-FIRST-WRITE

: (MF.CAPTURED>FILE0)  ( -- write captured MIDI to file format 0)
    0 0 ed.at: captured-midi mf-event-time !
    many: captured-midi 0
    DO i get: captured-midi midi.unpack
       rot mf.write.event
    LOOP
    mf-start-pos @ mf.end.format0
;

: }MIDIFILE0  ( -- )
    if-capturing @
    IF  (mf.captured>file0)
        }capture
    THEN
;

: $CAPTURED>MIDIFILE0  ( $filename -- )
    $mf.begin.format0 mf-start-pos !  ( use filename while still valid )
    (mf.captured>file0)
;

: $MIDIFILE0{  ( $filename -- , start capturing MIDI data )
    }midifile0
    $mf.begin.format0 mf-start-pos !  ( use filename while still valid )
    capture{
;

: MIDIFILE0{ ( <name> -- )
    fileword $midifile0{
;

CREATE MF-COUNT-CAPS 16 allot

: CAP.GET.CHAN  ( status-byte -- channel# )
    $ 0F and 1+
;

: CAP.COUNT.CHANS ( -- #channels , count captured track/channels )
    16 0
    DO 0 i mf-count-caps + c!
    LOOP
\
    many: captured-midi 0
    DO i get: captured-midi midi.unpack drop c@
        cap.get.chan 1-
        nip
        mf-count-caps + 1 swap c!  ( set flag in array )
    LOOP
\
    0
    16 0
    DO i mf-count-caps + c@ +
    LOOP
;

: (MF.CAPTURED>FILE1)  ( -- , write tracks with data to metafile )
    cap.count.chans ( #chans )
    \ write a track zero that should contain tempo maps
    1+ \ for track zero
    mf.begin.track  ( -- pos )
    mf.write.end
    mf.end.track
    \ Write each track with sequence number
    16 0
    DO i mf-count-caps + c@
        IF
            mf.begin.track  ( -- pos )
            0 0 ed.at: captured-midi mf-event-time !
            i 1+ mf.write.seq#
            many: captured-midi 0
            DO
                i get: captured-midi midi.unpack
                over c@ cap.get.chan 1- j  = \ 00001
                IF
                    ( time addr count -- )
                    rot mf.write.event
                ELSE 2drop drop
                THEN
            LOOP
            mf.write.end
            mf.end.track
       THEN
    LOOP
    0 mf.seek
    1 swap ticks/beat @ mf.write.header
    mf.close
;

: }MIDIFILE1  ( -- )
    if-capturing @
    IF  (mf.captured>file1)
        }capture
    THEN
;

: $CAPTURED>MIDIFILE1  ( $filename -- )
    $mf.create
    1 1 ticks/beat @ mf.write.header
    (mf.captured>file1)
;

: $MIDIFILE1{  ( $filename -- , start capturing MIDI data )
    }midifile1
     $mf.create
    1 1 ticks/beat @ mf.write.header
    capture{
;

: MIDIFILE1{ ( <name> -- )
    fileword $midifile1{
;

\ set aliases to format 0 for compatibility with old code
: MIDIFILE{ midifile0{ ;
: $MIDIFILE{ $midifile0{ ;
: }MIDIFILE }midifile0 ;

if.forgotten }midifile0

: tmf
    " testzz5.mid" $midifile0{
    rnow 55 60 midi.noteon
    200 vtime+!
    55 0 midi.noteoff
    }midifile0
;


Fix for 32-bit ism in core test

Fix for 32-bit ism in core test

\ Additional tests on the the ANS Forth Core word set

\ This program was written by Gerry Jackson in 2007, with contributions from
\ others where indicated, and is in the public domain - it can be distributed
\ and/or modified in any way but please retain this notice.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

\ The tests are not claimed to be comprehensive or correct

\ ------------------------------------------------------------------------------
\ Version 0.11 25 April 2015 Number prefixes # $ % and 'c' character input tested
\         0.10 3 August 2014 Test IMMEDIATE doesn't toggle an immediate flag
\         0.3  1 April 2012 Tests placed in the public domain.
\              Testing multiple ELSE's.
\              Further tests on DO +LOOPs.
\              Ackermann function added to test RECURSE.
\              >IN manipulation in interpreter mode
\              Immediate CONSTANTs, VARIABLEs and CREATEd words tests.
\              :NONAME with RECURSE moved to core extension tests.
\              Parsing behaviour of S" ." and ( tested
\         0.2  6 March 2009 { and } replaced with T{ and }T
\              Added extra RECURSE tests
\         0.1  20 April 2007 Created
\ ------------------------------------------------------------------------------
\ The tests are based on John Hayes test program for the core word set
\
\ This file provides some more tests on Core words where the original Hayes
\ tests are thought to be incomplete
\
\ Words tested in this file are:
\     DO +LOOP RECURSE ELSE >IN IMMEDIATE
\ ------------------------------------------------------------------------------
\ Assumptions and dependencies:
\     - tester.fr or ttester.fs has been loaded prior to this file
\     - core.fr has been loaded so that constants MAX-INT, MIN-INT and
\       MAX-UINT are defined
\ ------------------------------------------------------------------------------

DECIMAL

TESTING DO +LOOP with run-time increment, negative increment, infinite loop
\ Contributed by Reinhold Straub

VARIABLE ITERATIONS
VARIABLE INCREMENT
: GD7 ( LIMIT START INCREMENT -- )
   INCREMENT !
   0 ITERATIONS !
   DO
      1 ITERATIONS +!
      I
      ITERATIONS @  6 = IF LEAVE THEN
      INCREMENT @
   +LOOP ITERATIONS @
;

T{  4  4 -1 GD7 -> 4 1 }T
T{  1  4 -1 GD7 -> 4 3 2 1 4 }T
T{  4  1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T
T{  4  1  0 GD7 -> 1 1 1 1 1 1 6 }T
T{  0  0  0 GD7 -> 0 0 0 0 0 0 6 }T
T{  1  4  0 GD7 -> 4 4 4 4 4 4 6 }T
T{  1  4  1 GD7 -> 4 5 6 7 8 9 6 }T
T{  4  1  1 GD7 -> 1 2 3 3 }T
T{  4  4  1 GD7 -> 4 5 6 7 8 9 6 }T
T{  2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T
T{ -1  2 -1 GD7 -> 2 1 0 -1 4 }T
T{  2 -1  0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T
T{ -1  2  0 GD7 -> 2 2 2 2 2 2 6 }T
T{ -1  2  1 GD7 -> 2 3 4 5 6 7 6 }T
T{  2 -1  1 GD7 -> -1 0 1 3 }T
T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T
T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T
T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T

\ ------------------------------------------------------------------------------
TESTING DO +LOOP with large and small increments

\ Contributed by Andrew Haley

MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP
USTEP NEGATE CONSTANT -USTEP
MAX-INT 7 RSHIFT 1+ CONSTANT STEP
STEP NEGATE CONSTANT -STEP

VARIABLE BUMP

T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T

T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T
T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T

T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T
T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T

\ Two's complement arithmetic, wraps around modulo wordsize
\ Only tested if the Forth system does wrap around, use of conditional
\ compilation deliberately avoided

MAX-INT 1+ MIN-INT = CONSTANT +WRAP?
MIN-INT 1- MAX-INT = CONSTANT -WRAP?
MAX-UINT 1+ 0=       CONSTANT +UWRAP?
0 1- MAX-UINT =      CONSTANT -UWRAP?

: GD9  ( n limit start step f result -- )
   >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T
;

T{ 0 0 0  USTEP +UWRAP? 256 GD9
T{ 0 0 0 -USTEP -UWRAP?   1 GD9
T{ 0 MIN-INT MAX-INT  STEP +WRAP? 1 GD9
T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9

\ ------------------------------------------------------------------------------
TESTING DO +LOOP with maximum and minimum increments

: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
(-MI) CONSTANT -MAX-INT

T{ 0 1 0 MAX-INT GD8  -> 1 }T
T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8  -> 2 }T

T{ 0 MAX-INT  0 MAX-INT GD8  -> 1 }T
T{ 0 MAX-INT  1 MAX-INT GD8  -> 1 }T
T{ 0 MAX-INT -1 MAX-INT GD8  -> 2 }T
T{ 0 MAX-INT DUP 1- MAX-INT GD8  -> 1 }T

T{ 0 MIN-INT 1+   0 MIN-INT GD8  -> 1 }T
T{ 0 MIN-INT 1+  -1 MIN-INT GD8  -> 1 }T
T{ 0 MIN-INT 1+   1 MIN-INT GD8  -> 2 }T
T{ 0 MIN-INT 1+ DUP MIN-INT GD8  -> 1 }T

\ ------------------------------------------------------------------------------
TESTING multiple RECURSEs in one colon definition

: ACK ( m n -- u )    \ Ackermann function, from Rosetta Code
   OVER 0= IF  NIP 1+ EXIT  THEN       \ ack(0, n) = n+1
   SWAP 1- SWAP                        ( -- m-1 n )
   DUP  0= IF  1+  RECURSE EXIT  THEN  \ ack(m, 0) = ack(m-1, 1)
   1- OVER 1+ SWAP RECURSE RECURSE     \ ack(m, n) = ack(m-1, ack(m,n-1))
;

T{ 0 0 ACK ->  1 }T
T{ 3 0 ACK ->  5 }T
T{ 2 4 ACK -> 11 }T

\ ------------------------------------------------------------------------------
TESTING multiple ELSE's in an IF statement
\ Discussed on comp.lang.forth and accepted as valid ANS Forth

: MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ;
T{ 0 MELSE -> 2 4 }T
T{ -1 MELSE -> 1 3 5 }T

\ ------------------------------------------------------------------------------
TESTING manipulation of >IN in interpreter mode

.( Start ) cr
T{ 12345 DEPTH OVER 9 < 34 AND + 3 + >IN ! -> 12345 2345 345 45 5 }T
T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T

\ ------------------------------------------------------------------------------
TESTING IMMEDIATE with CONSTANT  VARIABLE and CREATE [ ... DOES> ]

T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T
T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T
T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T
T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T
T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T
T{ CREATE IW5 456 , IMMEDIATE -> }T
T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T
T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
T{ 111 IW6 IW7 IW7 -> 112 }T
T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T
T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
: FIND-IW BL WORD FIND NIP ;  ( -- 0 | 1 | -1 )
T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T   \ IW10 is not immediate
T{ IW10 FIND-IW IW10 -> 224 1 }T        \ IW10 becomes immediate

\ ------------------------------------------------------------------------------
TESTING that IMMEDIATE doesn't toggle a flag

VARIABLE IT1 0 IT1 !
: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE
T{ : IT3 IT2 ; IT1 @ -> 1234 }T

\ ------------------------------------------------------------------------------
TESTING parsing behaviour of S" ." and (
\ which should parse to just beyond the terminating character no space needed

T{ : GC5 S" A string"2DROP ; GC5 -> }T
T{ ( A comment)1234 -> 1234 }T
T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T

\ ------------------------------------------------------------------------------
TESTING number prefixes # $ % and 'c' character input
\ Adapted from the Forth 200X Draft 14.5 document

VARIABLE OLD-BASE
DECIMAL BASE @ OLD-BASE !
T{ #1289 -> 1289 }T
T{ #12346789. -> 12346789. }T
T{ #-1289 -> -1289 }T
T{ #-12346789. -> -12346789. }T
T{ $12eF -> 4847 }T
T{ $12aBcDeF. -> 313249263. }T
T{ $-12eF -> -4847 }T
T{ $-12AbCdEf. -> -313249263. }T
T{ %10010110 -> 150 }T
T{ %10010110. -> 150. }T
T{ %-10010110 -> -150 }T
T{ %-10010110. -> -150. }T
T{ 'z' -> 122 }T
\ Check BASE is unchanged
T{ BASE @ OLD-BASE @ = -> TRUE }T

\ Repeat in Hex mode
16 OLD-BASE ! 16 BASE !
T{ #1289 -> 509 }T                  \ 2
T{ #12346789. -> BC65A5. }T         \ 2
T{ #-1289 -> -509 }T                \ 2
T{ #-12346789. -> -BC65A5. }T       \ 2
T{ $12eF -> 12EF }T                 \ 2
T{ $12aBcDeF. -> 12AbCdeF. }T       \ 2
T{ $-12eF -> -12EF }T               \ 2
T{ $-12AbCdEf. -> -12ABCDef. }T     \ 2
T{ %10010110 -> 96 }T               \ 2
T{ %10010110. -> 96. }T             \ 2
T{ %-10010110 -> -96 }T             \ 2
T{ %-10010110. -> -96. }T           \ 2
T{ 'z' -> 7a }T                     \ 2
\ Check BASE is unchanged
T{ BASE @ OLD-BASE @ = -> TRUE }T   \ 2

DECIMAL
\ Check number prefixes in compile mode
T{ : nmp  #8327. $-2cbe %011010111 ''' ; nmp -> 8327. -11454 215 39 }T

\ ------------------------------------------------------------------------------

CR .( End of additional Core tests) CR

\ Additional tests on the the ANS Forth Core word set

\ This program was written by Gerry Jackson in 2007, with contributions from
\ others where indicated, and is in the public domain - it can be distributed
\ and/or modified in any way but please retain this notice.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

\ The tests are not claimed to be comprehensive or correct

\ ------------------------------------------------------------------------------
\ Version 0.11 25 April 2015 Number prefixes # $ % and 'c' character input tested
\         0.10 3 August 2014 Test IMMEDIATE doesn't toggle an immediate flag
\         0.3  1 April 2012 Tests placed in the public domain.
\              Testing multiple ELSE's.
\              Further tests on DO +LOOPs.
\              Ackermann function added to test RECURSE.
\              >IN manipulation in interpreter mode
\              Immediate CONSTANTs, VARIABLEs and CREATEd words tests.
\              :NONAME with RECURSE moved to core extension tests.
\              Parsing behaviour of S" ." and ( tested
\         0.2  6 March 2009 { and } replaced with T{ and }T
\              Added extra RECURSE tests
\         0.1  20 April 2007 Created
\ ------------------------------------------------------------------------------
\ The tests are based on John Hayes test program for the core word set
\
\ This file provides some more tests on Core words where the original Hayes
\ tests are thought to be incomplete
\
\ Words tested in this file are:
\     DO +LOOP RECURSE ELSE >IN IMMEDIATE
\ ------------------------------------------------------------------------------
\ Assumptions and dependencies:
\     - tester.fr or ttester.fs has been loaded prior to this file
\     - core.fr has been loaded so that constants MAX-INT, MIN-INT and
\       MAX-UINT are defined
\ ------------------------------------------------------------------------------

DECIMAL

TESTING DO +LOOP with run-time increment, negative increment, infinite loop
\ Contributed by Reinhold Straub

VARIABLE ITERATIONS
VARIABLE INCREMENT
: GD7 ( LIMIT START INCREMENT -- )
   INCREMENT !
   0 ITERATIONS !
   DO
      1 ITERATIONS +!
      I
      ITERATIONS @  6 = IF LEAVE THEN
      INCREMENT @
   +LOOP ITERATIONS @
;

T{  4  4 -1 GD7 -> 4 1 }T
T{  1  4 -1 GD7 -> 4 3 2 1 4 }T
T{  4  1 -1 GD7 -> 1 0 -1 -2 -3 -4 6 }T
T{  4  1  0 GD7 -> 1 1 1 1 1 1 6 }T
T{  0  0  0 GD7 -> 0 0 0 0 0 0 6 }T
T{  1  4  0 GD7 -> 4 4 4 4 4 4 6 }T
T{  1  4  1 GD7 -> 4 5 6 7 8 9 6 }T
T{  4  1  1 GD7 -> 1 2 3 3 }T
T{  4  4  1 GD7 -> 4 5 6 7 8 9 6 }T
T{  2 -1 -1 GD7 -> -1 -2 -3 -4 -5 -6 6 }T
T{ -1  2 -1 GD7 -> 2 1 0 -1 4 }T
T{  2 -1  0 GD7 -> -1 -1 -1 -1 -1 -1 6 }T
T{ -1  2  0 GD7 -> 2 2 2 2 2 2 6 }T
T{ -1  2  1 GD7 -> 2 3 4 5 6 7 6 }T
T{  2 -1  1 GD7 -> -1 0 1 3 }T
T{ -20 30 -10 GD7 -> 30 20 10 0 -10 -20 6 }T
T{ -20 31 -10 GD7 -> 31 21 11 1 -9 -19 6 }T
T{ -20 29 -10 GD7 -> 29 19 9 -1 -11 5 }T

\ ------------------------------------------------------------------------------
TESTING DO +LOOP with large and small increments

\ Contributed by Andrew Haley

MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP
USTEP NEGATE CONSTANT -USTEP
MAX-INT 7 RSHIFT 1+ CONSTANT STEP
STEP NEGATE CONSTANT -STEP

VARIABLE BUMP

T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; -> }T

T{ 0 MAX-UINT 0 USTEP GD8 -> 256 }T
T{ 0 0 MAX-UINT -USTEP GD8 -> 256 }T

T{ 0 MAX-INT MIN-INT STEP GD8 -> 256 }T
T{ 0 MIN-INT MAX-INT -STEP GD8 -> 256 }T

\ Two's complement arithmetic, wraps around modulo wordsize
\ Only tested if the Forth system does wrap around, use of conditional
\ compilation deliberately avoided

MAX-INT 1+ MIN-INT = CONSTANT +WRAP?
MIN-INT 1- MAX-INT = CONSTANT -WRAP?
MAX-UINT 1+ 0=       CONSTANT +UWRAP?
0 1- MAX-UINT =      CONSTANT -UWRAP?

: GD9  ( n limit start step f result -- )
   >R IF GD8 ELSE 2DROP 2DROP R@ THEN -> R> }T
;

T{ 0 0 0  USTEP +UWRAP? 256 GD9
T{ 0 0 0 -USTEP -UWRAP?   1 GD9
T{ 0 MIN-INT MAX-INT  STEP +WRAP? 1 GD9
T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9

\ ------------------------------------------------------------------------------
TESTING DO +LOOP with maximum and minimum increments

: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ;
(-MI) CONSTANT -MAX-INT

T{ 0 1 0 MAX-INT GD8  -> 1 }T
T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8  -> 2 }T

T{ 0 MAX-INT  0 MAX-INT GD8  -> 1 }T
T{ 0 MAX-INT  1 MAX-INT GD8  -> 1 }T
T{ 0 MAX-INT -1 MAX-INT GD8  -> 2 }T
T{ 0 MAX-INT DUP 1- MAX-INT GD8  -> 1 }T

T{ 0 MIN-INT 1+   0 MIN-INT GD8  -> 1 }T
T{ 0 MIN-INT 1+  -1 MIN-INT GD8  -> 1 }T
T{ 0 MIN-INT 1+   1 MIN-INT GD8  -> 2 }T
T{ 0 MIN-INT 1+ DUP MIN-INT GD8  -> 1 }T

\ ------------------------------------------------------------------------------
TESTING multiple RECURSEs in one colon definition

: ACK ( m n -- u )    \ Ackermann function, from Rosetta Code
   OVER 0= IF  NIP 1+ EXIT  THEN       \ ack(0, n) = n+1
   SWAP 1- SWAP                        ( -- m-1 n )
   DUP  0= IF  1+  RECURSE EXIT  THEN  \ ack(m, 0) = ack(m-1, 1)
   1- OVER 1+ SWAP RECURSE RECURSE     \ ack(m, n) = ack(m-1, ack(m,n-1))
;

T{ 0 0 ACK ->  1 }T
T{ 3 0 ACK ->  5 }T
T{ 2 4 ACK -> 11 }T

\ ------------------------------------------------------------------------------
TESTING multiple ELSE's in an IF statement
\ Discussed on comp.lang.forth and accepted as valid ANS Forth

: MELSE IF 1 ELSE 2 ELSE 3 ELSE 4 ELSE 5 THEN ;
T{ 0 MELSE -> 2 4 }T
T{ -1 MELSE -> 1 3 5 }T

\ ------------------------------------------------------------------------------
TESTING manipulation of >IN in interpreter mode

T{ 123456 DEPTH OVER 9 < 35 AND + 3 + >IN ! -> 123456 23456 3456 456 56 6 }T
T{ 14145 8115 ?DUP 0= 34 AND >IN +! TUCK MOD 14 >IN ! GCD CALCULATION -> 15 }T

\ ------------------------------------------------------------------------------
TESTING IMMEDIATE with CONSTANT  VARIABLE and CREATE [ ... DOES> ]

T{ 123 CONSTANT IW1 IMMEDIATE IW1 -> 123 }T
T{ : IW2 IW1 LITERAL ; IW2 -> 123 }T
T{ VARIABLE IW3 IMMEDIATE 234 IW3 ! IW3 @ -> 234 }T
T{ : IW4 IW3 [ @ ] LITERAL ; IW4 -> 234 }T
T{ :NONAME [ 345 ] IW3 [ ! ] ; DROP IW3 @ -> 345 }T
T{ CREATE IW5 456 , IMMEDIATE -> }T
T{ :NONAME IW5 [ @ IW3 ! ] ; DROP IW3 @ -> 456 }T
T{ : IW6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
T{ 111 IW6 IW7 IW7 -> 112 }T
T{ : IW8 IW7 LITERAL 1+ ; IW8 -> 113 }T
T{ : IW9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
: FIND-IW BL WORD FIND NIP ;  ( -- 0 | 1 | -1 )
T{ 222 IW9 IW10 FIND-IW IW10 -> -1 }T   \ IW10 is not immediate
T{ IW10 FIND-IW IW10 -> 224 1 }T        \ IW10 becomes immediate

\ ------------------------------------------------------------------------------
TESTING that IMMEDIATE doesn't toggle a flag

VARIABLE IT1 0 IT1 !
: IT2 1234 IT1 ! ; IMMEDIATE IMMEDIATE
T{ : IT3 IT2 ; IT1 @ -> 1234 }T

\ ------------------------------------------------------------------------------
TESTING parsing behaviour of S" ." and (
\ which should parse to just beyond the terminating character no space needed

T{ : GC5 S" A string"2DROP ; GC5 -> }T
T{ ( A comment)1234 -> 1234 }T
T{ : PB1 CR ." You should see 2345: "." 2345"( A comment) CR ; PB1 -> }T

\ ------------------------------------------------------------------------------
TESTING number prefixes # $ % and 'c' character input
\ Adapted from the Forth 200X Draft 14.5 document

VARIABLE OLD-BASE
DECIMAL BASE @ OLD-BASE !
T{ #1289 -> 1289 }T
T{ #12346789. -> 12346789. }T
T{ #-1289 -> -1289 }T
T{ #-12346789. -> -12346789. }T
T{ $12eF -> 4847 }T
T{ $12aBcDeF. -> 313249263. }T
T{ $-12eF -> -4847 }T
T{ $-12AbCdEf. -> -313249263. }T
T{ %10010110 -> 150 }T
T{ %10010110. -> 150. }T
T{ %-10010110 -> -150 }T
T{ %-10010110. -> -150. }T
T{ 'z' -> 122 }T
\ Check BASE is unchanged
T{ BASE @ OLD-BASE @ = -> TRUE }T

\ Repeat in Hex mode
16 OLD-BASE ! 16 BASE !
T{ #1289 -> 509 }T                  \ 2
T{ #12346789. -> BC65A5. }T         \ 2
T{ #-1289 -> -509 }T                \ 2
T{ #-12346789. -> -BC65A5. }T       \ 2
T{ $12eF -> 12EF }T                 \ 2
T{ $12aBcDeF. -> 12AbCdeF. }T       \ 2
T{ $-12eF -> -12EF }T               \ 2
T{ $-12AbCdEf. -> -12ABCDef. }T     \ 2
T{ %10010110 -> 96 }T               \ 2
T{ %10010110. -> 96. }T             \ 2
T{ %-10010110 -> -96 }T             \ 2
T{ %-10010110. -> -96. }T           \ 2
T{ 'z' -> 7a }T                     \ 2
\ Check BASE is unchanged
T{ BASE @ OLD-BASE @ = -> TRUE }T   \ 2

DECIMAL
\ Check number prefixes in compile mode
T{ : nmp  #8327. $-2cbe %011010111 ''' ; nmp -> 8327. -11454 215 39 }T

\ ------------------------------------------------------------------------------

CR .( End of additional Core tests) CR


Now I see the error of my ways.

Now I see the error of my ways.

Previous revision of this file changed the "boot" commands to take
no arguments from the stack. This is only valid in the case where
a kernel has not been loaded. In that case, load_kernel_and_modules
will be called, which takes a list of arguments from the stack.

When a kernel is presently loaded, though, the list of arguments must
be passed to the boot command, which was the behaviour before the last
revision.

Fix things for both cases.

Noticed by: S-Max and others on that chat room

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

s" arch-alpha" environment? [if] [if]
	s" loader_version" environment?  [if]
		11 < [if]
			.( Loader version 1.1+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

s" arch-i386" environment? [if] [if]
	s" loader_version" environment?  [if]
		10 < [if]
			.( Loader version 1.0+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

include /boot/support.4th

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

only forth also support-functions also builtins definitions

: boot
  0= if ( interpreted ) get_arguments then

  \ Unload only if a path was passed
  dup if
    >r over r> swap
    c@ [char] - <> if
      0 1 unload drop
    else
      s" kernelname" getenv? if ( a kernel has been loaded )
        1 boot exit
      then
      load_kernel_and_modules
      ?dup if exit then
      0 1 boot exit
    then
  else
    s" kernelname" getenv? if ( a kernel has been loaded )
      1 boot exit
    then
    load_kernel_and_modules
    ?dup if exit then
    0 1 boot exit
  then
  load_kernel_and_modules
  ?dup 0= if 0 1 boot then
;

: boot-conf
  0= if ( interpreted ) get_arguments then
  0 1 unload drop
  load_kernel_and_modules
  ?dup 0= if 0 1 autoboot then
;

also forth definitions also builtins

builtin: boot
builtin: boot-conf

only forth definitions also support-functions

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

\ Words to be used inside configuration files

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

\ Return to strict forth vocabulary

: #type
  over - >r
  type
  r> spaces
;

: .? 2 spaces 2swap 15 #type 2 spaces type cr ;

: ?
  ['] ? execute
  s" boot-conf" s" load kernel and modules, then autoboot" .?
  s" read-conf" s" read a configuration file" .?
  s" enable-module" s" enable loading of a module" .?
  s" disable-module" s" disable loading of a module" .?
  s" toggle-module" s" toggle loading of a module" .?
  s" show-module" s" show module load data" .?
;

only forth also

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

s" arch-alpha" environment? [if] [if]
	s" loader_version" environment?  [if]
		11 < [if]
			.( Loader version 1.1+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

s" arch-i386" environment? [if] [if]
	s" loader_version" environment?  [if]
		10 < [if]
			.( Loader version 1.0+ required) cr
			abort
		[then]
	[else]
		.( Could not get loader version!) cr
		abort
	[then]
[then] [then]

include /boot/support.4th

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

only forth also support-functions also builtins definitions

: boot
  0= if ( interpreted ) get_arguments then

  \ Unload only if a path was passed
  dup if
    >r over r> swap
    c@ [char] - <> if
      0 1 unload drop
    else
      s" kernelname" getenv? 0= if ( no kernel has been loaded )
	load_kernel_and_modules
	?dup if exit then
      then
      0 1 boot exit
    then
  else
    s" kernelname" getenv? 0= if ( no kernel has been loaded )
      load_kernel_and_modules
      ?dup if exit then
    then
    0 1 boot exit
  then
  load_kernel_and_modules
  ?dup 0= if 0 1 boot then
;

: boot-conf
  0= if ( interpreted ) get_arguments then
  0 1 unload drop
  load_kernel_and_modules
  ?dup 0= if 0 1 autoboot then
;

also forth definitions also builtins

builtin: boot
builtin: boot-conf

only forth definitions also support-functions

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

\ Words to be used inside configuration files

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

\ Return to strict forth vocabulary

: #type
  over - >r
  type
  r> spaces
;

: .? 2 spaces 2swap 15 #type 2 spaces type cr ;

: ?
  ['] ? execute
  s" boot-conf" s" load kernel and modules, then autoboot" .?
  s" read-conf" s" read a configuration file" .?
  s" enable-module" s" enable loading of a module" .?
  s" disable-module" s" disable loading of a module" .?
  s" toggle-module" s" toggle loading of a module" .?
  s" show-module" s" show module load data" .?
;

only forth also


Fix a stack leak in [unused] cycle_menuitem function while we're here
(required misconfiguration and/or missing environment vars to occur).

Reviewed by:	peterj, adrian (co-mentor)
Approved by:	adrian (co-mentor)


Added unless, rot, ?dup

Added unless, rot, ?dup

( bootstrap remainder of interpreter )
( load into machine running outer interpreter image )

create : compile create compile ; ( magic! )

( assembler )

: x 1 ; ( shared by outer interpreter )
: d 2 ; ( dictionary pointer - shared by outer interpreter )
: zero 4 ; ( shared by outer interpreter )
: y 30 ;
: z 31 ;

: [ interact ; immediate
: ] compile ;

: cp, 3 , , , ;
: popxy popx [ x y cp, ] popx ;
: pushxy pushx [ y x cp, ] pushx ;

: xor, 15 , , , , ;
: swap popxy [ x y x xor, x y y xor, x y x xor, ] pushxy ;

: ldc,   0 , , , ;
: ld,    1 , , , ;
: st,    2 , , , ;
: in,    4 , , ;
: out,   5 , , ;
: inc,   6 , , , ;
: dec,   7 , , , ;
: add,   8 , , , , ;
: sub,   9 , , swap , , ;
: mul,  10 , , , , ;
: div,  11 , , swap , , ;
: mod,  12 , , swap , , ;
: and,  13 , , , , ;
: or,   14 , , , , ;
: not,  16 , , , ;
: shr,  17 , , swap , , ;
: shl,  18 , , swap , , ;
: beq,  19 , , , , ;
: bne,  20 , , , , ;
: bgt,  21 , , swap , , ;
: bge,  22 , , swap , , ;
: blt,  23 , , swap , , ;
: ble,  24 , , swap , , ;
: exec, 25 , , ;
: jump, 26 , , ;
: call, 27 , , ;
: ret,  28 , ;
: halt, 29 , ;
: dump, 30 , ;

( instruction words )

: +    popxy [ x y x add, ] pushx ;
: -    popxy [ x y x sub, ] pushx ;
: *    popxy [ x y x mul, ] pushx ;
: /    popxy [ x y x div, ] pushx ;
: mod  popxy [ x y x mod, ] pushx ;
: 2/   popxy [ x y x shr, ] pushx ;
: 2*   popxy [ x y x shl, ] pushx ;
: and  popxy [ x y x and, ] pushx ;
: or   popxy [ x y x or,  ] pushx ;
: xor  popxy [ x y x xor, ] pushx ;
: not  popx [ x x not, ] pushx ;
: 1+   popx [ x x inc, ] pushx ;
: 1-   popx [ x x dec, ] pushx ;
: exec popx [ x exec, ] ;
: dump [ dump, ] ;
: exit [ halt, ] ;

( stack manipulation )

: drop ( a- ) popx ;
: 2drop ( ab- ) drop drop ;
: dup ( a-aa ) popx pushx pushx ;
: over ( ab-aba ) popxy pushx pushx [ y x cp, ] pushx swap ;
: 2dup ( ab-abab ) over over ;
: nip ( ab-b ) swap drop ;
: tuck ( ab-bab ) swap over ;
: -rot ( abc-cab ) swap popxy pushx [ y z cp, ] swap [ z x cp, ] pushx ;
: rot ( abs-bca ) -rot -rot ;

( vocabulary )

: true -1 ;
: false 0 ;

: key [ x in, ] pushx ;
: emit popx [ x out, ] ;
: cr 10 emit ;
: space 32 emit ;

: @ popx [ x x ld, ] pushx ;
: ! popxy [ x y st, ] ;

: allot [ d x cp, ] pushx swap popx [ x d d add, ] ;

: here@ [ d x cp, ] pushx ;
: here! popx [ x d cp, ] ;

: >dfa 2 + ;
: ' find >dfa ;

: if [ ' popxy literal ] call, here@ 1+ zero x 0 beq, ; immediate
: unless [ ' popxy literal ] call, here@ 1+ zero x 0 bne, ; immediate
: else here@ 1+ 0 jump, swap here@ swap ! ; immediate
: then here@ swap ! ; immediate

: = popxy 0 [ x y here@ 6 + bne, ] not ;
: <> popxy 0 [ x y here@ 6 + beq, ] not ;
: > popxy 0 [ x y here@ 6 + ble, ] not ;
: < popxy 0 [ x y here@ 6 + bge, ] not ;
: >= popxy 0 [ x y here@ 6 + blt, ] not ;
: <= popxy 0 [ x y here@ 6 + bgt, ] not ;

: sign 0 < if -1 else 1 then ;
: /mod 2dup / -rot mod ;

: min 2dup > if swap then drop ;
: max 2dup < if swap then drop ;

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

: .sign dup sign negate 44 + emit ; ( happens 44 +/- 1 is ASCII '-'/'+' )
: .dig 10 /mod swap ;
: .digemit 48 + emit ;  ( 48 is ASCII '0' )
: . .sign .dig .dig .dig .dig .dig drop .digemit .digemit .digemit .digemit .digemit cr ;

: ?dup dup unless drop then ;

( bootstrap remainder of interpreter )
( load into machine running outer interpreter image )

create : compile create compile ; ( magic! )

( assembler )

: x 1 ; ( shared by outer interpreter )
: d 2 ; ( dictionary pointer - shared by outer interpreter )
: zero 4 ; ( shared by outer interpreter )
: y 30 ;
: z 31 ;

: [ interact ; immediate
: ] compile ;

: cp, 3 , , , ;
: popxy popx [ x y cp, ] popx ;
: pushxy pushx [ y x cp, ] pushx ;

: xor, 15 , , , , ;
: swap popxy [ x y x xor, x y y xor, x y x xor, ] pushxy ;

: ldc,   0 , , , ;
: ld,    1 , , , ;
: st,    2 , , , ;
: in,    4 , , ;
: out,   5 , , ;
: inc,   6 , , , ;
: dec,   7 , , , ;
: add,   8 , , , , ;
: sub,   9 , , swap , , ;
: mul,  10 , , , , ;
: div,  11 , , swap , , ;
: mod,  12 , , swap , , ;
: and,  13 , , , , ;
: or,   14 , , , , ;
: not,  16 , , , ;
: shr,  17 , , swap , , ;
: shl,  18 , , swap , , ;
: beq,  19 , , , , ;
: bne,  20 , , , , ;
: bgt,  21 , , swap , , ;
: bge,  22 , , swap , , ;
: blt,  23 , , swap , , ;
: ble,  24 , , swap , , ;
: exec, 25 , , ;
: jump, 26 , , ;
: call, 27 , , ;
: ret,  28 , ;
: halt, 29 , ;
: dump, 30 , ;

( instruction words )

: +    popxy [ x y x add, ] pushx ;
: -    popxy [ x y x sub, ] pushx ;
: *    popxy [ x y x mul, ] pushx ;
: /    popxy [ x y x div, ] pushx ;
: mod  popxy [ x y x mod, ] pushx ;
: 2/   popxy [ x y x shr, ] pushx ;
: 2*   popxy [ x y x shl, ] pushx ;
: and  popxy [ x y x and, ] pushx ;
: or   popxy [ x y x or,  ] pushx ;
: xor  popxy [ x y x xor, ] pushx ;
: not  popx [ x x not, ] pushx ;
: 1+   popx [ x x inc, ] pushx ;
: 1-   popx [ x x dec, ] pushx ;
: exec popx [ x exec, ] ;
: dump [ dump, ] ;
: exit [ halt, ] ;

( stack manipulation )

: drop ( a- ) popx ;
: 2drop ( ab- ) drop drop ;
: dup ( a-aa ) popx pushx pushx ;
: over ( ab-aba ) popxy pushx pushx [ y x cp, ] pushx swap ;
: 2dup ( ab-abab ) over over ;
: nip ( ab-b ) swap drop ;
: tuck ( ab-bab ) swap over ;
: -rot ( abc-cab ) swap popxy pushx [ y z cp, ] swap [ z x cp, ] pushx ;

( vocabulary )

: true -1 ;
: false 0 ;

: key [ x in, ] pushx ;
: emit popx [ x out, ] ;
: cr 10 emit ;
: space 32 emit ;

: @ popx [ x x ld, ] pushx ;
: ! popxy [ x y st, ] ;

: allot [ d x cp, ] pushx swap popx [ x d d add, ] ;

: here@ [ d x cp, ] pushx ;
: here! popx [ x d cp, ] ;

: >dfa 2 + ;
: ' find >dfa ;

: if [ ' popxy literal ] call, here@ 1+ zero x 0 beq, ; immediate
: else here@ 1+ 0 jump, swap here@ swap ! ; immediate
: then here@ swap ! ; immediate

: = popxy 0 [ x y here@ 6 + bne, ] not ;
: <> popxy 0 [ x y here@ 6 + beq, ] not ;
: > popxy 0 [ x y here@ 6 + ble, ] not ;
: < popxy 0 [ x y here@ 6 + bge, ] not ;
: >= popxy 0 [ x y here@ 6 + blt, ] not ;
: <= popxy 0 [ x y here@ 6 + bgt, ] not ;

: sign 0 < if -1 else 1 then ;
: /mod 2dup / -rot mod ;

: min 2dup > if swap then drop ;
: max 2dup < if swap then drop ;

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

: .sign dup sign negate 44 + emit ; ( happens 44 +/- 1 is ASCII '-'/'+' )
: .dig 10 /mod swap ;
: .digemit 48 + emit ;  ( 48 is ASCII '0' )
: . .sign .dig .dig .dig .dig .dig drop .digemit .digemit .digemit .digemit .digemit cr ;