midifile: change use of CELL

midifile: change use of CELL

The old code was using CELL, which was 4 in the old days.
Now CELL is 8. But we still need 4 because that is the
size of the chunk and length fields in a MIDI file.

\ 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
4 constant MF_CHKID_SIZE  \ size of a length number in an SMF file
4 constant MF_LENGTH_SIZE  \ size of a length number in an SMF file
mf_chkid_size mf_length_size + constant MF_HEADER_SIZE
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 mf_header_size mf.read
    mf_header_size -
    IF ." Truncated chunk " r@ .chkid cr mf.error
    THEN
    rdrop
    mf-pad mf_chkid_size + 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 mf_chkid_size + be!
    mf-pad mf_header_size 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 mf_length_size - 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"
    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
;


Add ?DO word

Add ?DO word

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    16 + @ \ offset in execution token for alloc size
    cells swap >body swap
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: 'word  ( -- addr )  here ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) 34 parse ", ;

: .(  ( <string> --, type string delimited by parens )
    41 parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE 34 parse type
    THEN
; immediate

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

: DIGIT ( n -- ascii )
    dup 10 < IF 48 ELSE 87 THEN + ;

: SIGN ( n -- ) < 0 IF 45 hold THEN
;
: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body \ get address of code for new word
        cell + \ offset to second cell in create word
        !      \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
		>r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
		r>
        :noname       ( addrz xt )
        swap !              \ save execution token in literal
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
	dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
\ : CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    16 + @ \ offset in execution token for alloc size
    cells swap >body swap
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

: :NONAME  ( -- xt , begin compilation of headerless secondary ) align here ] ;

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: 'word  ( -- addr )  here ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) 34 parse ", ;

: .(  ( <string> --, type string delimited by parens )
    41 parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE 34 parse type
    THEN
; immediate

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

: DIGIT ( n -- ascii )
    dup 10 < IF 48 ELSE 87 THEN + ;

: SIGN ( n -- ) < 0 IF 45 hold THEN
;
: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body \ get address of code for new word
        cell + \ offset to second cell in create word
        !      \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
		>r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
		r>
        :noname       ( addrz xt )
        swap !              \ save execution token in literal
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
	dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

\ : ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
\        ?comp
\        ( leave address to set for forward branch )
\        compile  (?do)
\        here 0 ,
\        here >us do_flag  >us  ( for backward branch )
\        >us ( for forward branch ) ?do_flag >us
\ ; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;


ignore garbage from serial

ignore garbage from serial

marker task-menu.4th

include /boot/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

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

46 constant dot

\ The logo. It can be 19 rows high and 34 columns wide.
: display-logo ( x y -- )
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
at-xy ." "
;

variable vmguest
: set-vmguest ( -- )
	0 vmguest !
	s" smbios.system.product" getenv dup -1 <> if
		2dup s" VMware Virtual Platform" compare 0= if
			1 vmguest !
		then
		2dup s" VirtualBox" compare 0= if
			1 vmguest !
		then
		2dup s" Virtual Machine" compare 0= if
			s" smbios.system.maker" getenv dup -1 <> if
				s" Microsoft Corporation" compare 0= if
					1 vmguest !
				then
			else
				drop
			then
		then
		2drop
	else
		drop
	then
	vmguest @ 0 <> if
		s" 1" s" nas4free.vmguest" setenv
		s" kern.hz" getenv dup -1 <> if
			?number if
				100 > if
					s" 100" s" kern.hz" setenv
				then
			then
		else
			drop
			s" 100" s" kern.hz" setenv
		then
	else
		s" 0" s" nas4free.vmguest" setenv
	then
;

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

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

: display-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	77 20 2 2 box
	45 3 display-logo
	5 7 at-xy ." Welcome to NAS4Free!"
	printmenuitem ."  Boot NAS4Free in Normal Mode" bootkey !
	s" arch-i386" environment? if
		drop
		printmenuitem ."  Boot NAS4Free with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot NAS4Free in Safe Mode" bootsafekey !
	printmenuitem ."  Boot NAS4Free with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot system" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

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

set-current
set-vmguest

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

previous

marker task-menu.4th

include /boot/screen.4th
include /boot/frames.4th

hide

variable menuidx
variable menubllt
variable menuX
variable menuY
variable promptwidth

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

46 constant dot

\ The logo. It can be 19 rows high and 34 columns wide.
: display-logo ( x y -- )
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
2dup at-xy ." " 1+
at-xy ." "
;

variable vmguest
: set-vmguest ( -- )
	0 vmguest !
	s" smbios.system.product" getenv dup -1 <> if
		2dup s" VMware Virtual Platform" compare 0= if
			1 vmguest !
		then
		2dup s" VirtualBox" compare 0= if
			1 vmguest !
		then
		2dup s" Virtual Machine" compare 0= if
			s" smbios.system.maker" getenv dup -1 <> if
				s" Microsoft Corporation" compare 0= if
					1 vmguest !
				then
			else
				drop
			then
		then
		2drop
	else
		drop
	then
	vmguest @ 0 <> if
		s" 1" s" nas4free.vmguest" setenv
		s" kern.hz" getenv dup -1 <> if
			?number if
				100 > if
					s" 100" s" kern.hz" setenv
				then
			then
		else
			drop
			s" 100" s" kern.hz" setenv
		then
	else
		s" 0" s" nas4free.vmguest" setenv
	then
;

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

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

: display-menu ( -- )
	0 menuidx !
	dot menubllt !
	8 menuY !
	5 menuX !
	clear
	77 20 2 2 box
	45 3 display-logo
	5 7 at-xy ." Welcome to NAS4Free!"
	printmenuitem ."  Boot NAS4Free in Normal Mode" bootkey !
	s" arch-i386" environment? if
		drop
		printmenuitem ."  Boot NAS4Free with ACPI " bootacpikey !
		acpienabled? if
			." disabled"
		else
			." enabled"
		then
	else
		-2 bootacpikey !
	then
	printmenuitem ."  Boot NAS4Free in Safe Mode" bootsafekey !
	printmenuitem ."  Boot NAS4Free with verbose logging" bootverbosekey !
	printmenuitem ."  Escape to loader prompt" escapekey !
	printmenuitem ."  Reboot system" rebootkey !
	menuX @ 20 at-xy
	." Select option, [Enter] for default"
	menuX @ 21 at-xy
	s" or [Space] to pause timer    " dup 2 - promptwidth !
	type
;

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

set-current
set-vmguest

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

previous


Re-instituted IS word

Re-instituted IS word

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: <= ( a b -- f , true if A <= b ) > 0= ;
: >= ( a b -- f , true if A >= b ) < 0= ;
: NOT ( n -- !n , logical negation ) 0= ;
: DNEGATE ( d -- -d , negate by doing 0-d )
        0 swap -
;
: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
: CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: BETWEEN ( n lo hi -- flag , true if between lo & hi )
        >r over r> > >r
        < r> or 0=
;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    >body swap >size
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body   \ get address of code for new word
        3 cell* +      \ offset to EXIT cell in create word
        !              \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
        >r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
        r>
        :noname       ( addrz xt )
        compile rdrop       \ drop a stack frame (call becomes goto)
        swap !              \ save execution token in literal
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

: 2* ( n -- n*2 )
        2 *
;
: 2/ ( n -- n/2 )
        2 /
;

\ define some useful constants ------------------------------
1 0= constant FALSE
0 0= constant TRUE
32 constant BL

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
    dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: SPACE  bl emit ;
: 0SP depth 0 ?do drop loop ;

\ : >NEWLINE ( -- , CR if needed )
\         out @ 0>
\         IF cr
\         THEN
\ ;

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: DABS ( d -- |d| )
        dup 0<
        IF dnegate
        THEN
;

: S>D  ( s -- d , extend signed single precision to double )
        dup 0<
        IF -1
        ELSE 0
        THEN
;

: D>S ( d -- s ) drop ;

: PARSE-WORD ( "<spaces>name<space>" -- c-addr u ) bl parse ;
: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: $TYPE  ( $string -- ) count type ;
: 'word  ( -- addr )  here ;

: EVEN    ( addr -- addr' )   dup 1 and +  ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate

: .'   ( <string> -- , type string delimited by single quote )
        state @
        IF    compile (.")  [char] ' parse ",
        ELSE [char] ' parse type
        THEN
; immediate

: C"    ( <string> -- addr , return string address, ANSI )
        state @
        IF compile (c")   ,"
        ELSE [char] " parse pad place pad
        THEN
; immediate

: S"    ( <string> -- , -- addr , return string address, ANSI )
        state @
        IF compile (s")   ,"
        ELSE [char] " parse pad place pad count
        THEN
; immediate

: "    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate
: P"    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate

: ""  ( <string> -- addr )
       state @
       IF
               compile (C")
               bl parse-word  ",
       ELSE
               bl parse-word pad place pad
       THEN
; immediate

: SLITERAL ( addr cnt -- , compile string )
    compile (S")
    ",
; IMMEDIATE

: $APPEND ( addr count $1 -- , append text to $1 )
    over >r
        dup >r
    count +  ( -- a2 c2 end1 )
    swap cmove
    r> dup c@  ( a1 c1 )
    r> + ( -- a1 totalcount )
    swap c!
;

\ ANSI word to replace [COMPILE] and COMPILE ----------------
: POSTPONE  ( <name> -- )
	bl word find
	dup
    0= -13 ?ERROR
    0>
    IF compile,  \ immediate
    ELSE (compile)  \ normal
    THEN

; immediate

\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT  ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\    ." Begin AUTO.INIT ------" cr
;
: AUTO.TERM  ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\    ." End AUTO.TERM ------" cr
;

: INCLUDE? ( <word> <file> -- , load file if word not defined )
        bl word find
        IF drop bl word drop  ( eat word from source )
        ELSE drop include
        THEN
; immediate

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

\ ------------------------ INPUT -------------------------------

: SIGN ( n -- ) < 0 IF 45 hold THEN
;

: DIGIT ( n -- ascii )
   dup 10 < IF 48 ELSE 87 THEN + ;

: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: LWORD  ( char -- addr )
        parse-word here place here \ 00002 , use PARSE-WORD
;

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

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

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

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

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

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

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

\ : $ ( <number> -- N , convert next number as hex )
\     base @ hex
\     32 lword number? num_type_single = not
\     abort" Not a single number!"
\     swap base !
\     state @
\     IF [compile] literal
\     THEN
\ ; immediate

: (   41 parse 2drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note: default decimal numeric input mode. )

: \ ( <line> -- , comment out the rest of line)
   13 parse 2drop ; immediate

\ 1 echo !   \ Uncomment this line to echo Forth code while compiling.

\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ BYOK (portmanteau of BYE & OK) is a BYO kernel which happens to
\ implement a forth machine on i686 bare metal.
\
\ Substantial portions of this file were lifted straight from pForth
\ (http://pforth.googlecode.com/svn/trunk/fth/system.fth)
\ *********************************************************************
: BL 32 ;

: SPACE  ( -- )  bl emit ;
: CR  ( -- , cause output to appear at the beginning of the next line )  10 emit ;

: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1+ swap c@ ;

\ Miscellaneous support words
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

: <= ( a b -- f , true if A <= b ) > 0= ;
: >= ( a b -- f , true if A >= b ) < 0= ;
: NOT ( n -- !n , logical negation ) 0= ;
: DNEGATE ( d -- -d , negate by doing 0-d )
        0 swap -
;
: CELL+  ( n -- n+cell )  cell + ;
: CELL-  ( n -- n-cell )  cell - ;
: CELL*  ( n -- n*cell )  cells ;

: CHAR+  ( n -- n+size_of_char ) 1+ ;
: CHARS  ( n -- n*size_of_char, don't do anything ) ; immediate

\ useful stack manipulation words
: -ROT ( a b c -- c a b ) rot rot ;
: 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;

\ ------------------------------------------------------------------
: ID.  ( nfa -- ) count 31 and type ;

: BINARY    2 base ! ;
: OCTAL     8 base ! ;
: DECIMAL  10 base ! ;
: HEX      16 base ! ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;

: BETWEEN ( n lo hi -- flag , true if between lo & hi )
        >r over r> > >r
        < r> or 0=
;

: [  ( -- , enter interpreter mode )  0 state ! ; immediate
: ]  ( -- , enter compile mode )      1 state ! ;

: ?  ( <name> -- )  @ . ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ ' (lit) , cell 1- , ]  +
    [ ' (lit) , cell 1- invert , ]  and ;

: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT  ( nbytes -- , allot space in dictionary ) dp +! align ;

: C,  ( c -- ) here c! 1 dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

: SEE ( <name> -- )
    ' dup
    >body swap >size
    disassemble ;

\ Compiler support -------------------------------------------------
: COMPILE,   ( xt -- , compile call to xt ) , ;
: [COMPILE]  ( <name> -- , compile now even if immediate ) ' compile, ; immediate
: (COMPILE)  ( xt -- , postpone compilation of token )
    [compile] literal ( compile a call to literal )
    ( store xt of word to be compiled )

    [ ' compile, ] literal \ compile call to compile,
    compile, ;

: COMPILE  ( <name> --, save xt and compile later ) ' (compile) ; immediate

\ Error codes defined in ANSI Exception word set -------------------
: ERR_ABORT       -1 ;
: ERR_ABORTQ      -2 ;
: ERR_EXECUTING  -14 ;
: ERR_PAIRS      -22 ;

: ABORT ( i*x -- ) err_abort throw ;

\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION  ( f -- )  conditional_key - err_pairs ?error ;
: >MARK       ( -- addr )   here 0 , ;
: >RESOLVE    ( addr -- )   here over - swap ! ;
: <MARK       ( -- addr )   here ;
: <RESOLVE    ( addr -- )   here - , ;

: ?COMP  ( -- , error if not compiling ) state @ 0= err_executing ?error ;
: ?PAIRS ( n m -- ) - err_pairs ?error ;

\ Conditional primitives -------------------------------------------
: IF     ( -- f orig )  ?comp compile 0branch conditional_key >mark ; immediate
: THEN   ( f orig -- )  swap ?condition >resolve ; immediate
: BEGIN  ( -- f dest )  ?comp conditional_key <mark ; immediate
: AGAIN  ( f dest -- )  compile branch swap ?condition <resolve ; immediate
: UNTIL  ( f dest -- )  compile 0branch swap ?condition <resolve ; immediate
: AHEAD  ( -- f orig )  compile branch conditional_key >mark ; immediate

\ Conditionals built from primitives -------------------------------
: ELSE   ( f orig1 -- f orig2 )  [compile] ahead 2swap [compile] then ; immediate
: WHILE  ( f dest -- f origi f dest ) [compile] if 2swap ; immediate
: REPEAT  ( -- f orig f dest ) [compile] again [compile] then ; immediate

: [']  ( <name> -- xt , define compile time tick )
    ?comp ' [compile] literal
; immediate

: (DOES>)  ( xt -- , modify previous definition to execute code at xt )
        latest >body   \ get address of code for new word
        3 cell* +      \ offset to EXIT cell in create word
        !              \ store execution token of DOES> code in new word
;

: DOES>   ( -- , define execution code for CREATE word )
        0 [compile] literal \ dummy literal to hold xt
        here cell-          \ address of zero in literal
        compile (does>)     \ call (DOES>) from new creation word
        >r                  \ move addrz to return stack so ; doesn't see stack garbage
        [compile] ;         \ terminate part of code before does>
        r>
        :noname       ( addrz xt )
        compile rdrop       \ drop a stack frame (call becomes goto)
        swap !              \ save execution token in literal
; immediate

: 2! ( x1 x2 addr -- , store x2 followed by x1 )
        swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 )
        dup cell+ @ swap @ ;

: 2* ( n -- n*2 )
        2 *
;
: 2/ ( n -- n/2 )
        2 /
;

\ define some useful constants ------------------------------
1 0= constant FALSE
0 0= constant TRUE
32 constant BL

\ Stack data structure ----------------------------------------
\ This is a general purpose stack utility used to implement necessary
\ stacks for the compiler or the user.  Not real fast.
\ These stacks grow up which is different then normal.
\   cell 0 - stack pointer, offset from pfa of word
\   cell 1 - limit for range checking
\   cell 2 - first data location

: :STACK   ( #cells -- )
        CREATE  2 cells ,          ( offset of first data location )
                dup ,              ( limit for range checking, not currently used )
                cells cell+ allot  ( allot an extra cell for safety )
;

: >STACK  ( n stack -- , push onto stack, postincrement )
        dup @ 2dup cell+ swap ! ( -- n stack offset )
        + !
;

: STACK>  ( stack -- n , pop , predecrement )
        dup @ cell- 2dup swap !
        + @
;

: STACK@ ( stack -- n , copy )
        dup @ cell- + @
;

: STACK.PICK ( index stack -- n , grab Nth from top of stack )
        dup @ cell- +
        swap cells -   \ offset for index
        @
;
: STACKP ( stack -- ptr , to next empty location on stack )
    dup @ +
;

: 0STACKP  ( stack -- , clear stack)
    8 swap !
;

32 :stack ustack
ustack 0stackp

\ Define JForth like words.
: >US ustack >stack ;
: US> ustack stack> ;
: US@ ustack stack@ ;
: 0USP ustack 0stackp ;

\ DO LOOP ------------------------------------------------

3 constant do_flag
4 constant leave_flag
5 constant ?do_flag

: DO    ( -- , loop-back do_flag jump-from ?do_flag )
        ?comp
        compile  (do)
        here >us do_flag  >us  ( for backward branch )
; immediate

: ?DO    ( -- , loop-back do_flag jump-from ?do_flag  , on user stack )
        ?comp
        ( leave address to set for forward branch )
        compile  (?do)
        here 0 ,
        here >us do_flag  >us  ( for backward branch )
        >us ( for forward branch ) ?do_flag >us
; immediate

: LEAVE  ( -- addr leave_flag )
        compile (leave)
        here 0 , >us
        leave_flag >us
; immediate

: LOOP-FORWARD  ( -us- jump-from ?do_flag -- )
        BEGIN
                us@ leave_flag =
                us@ ?do_flag =
                OR
        WHILE
                us> leave_flag =
                IF
                        us> here over - cell+ swap !
                ELSE
                        us> dup
                        here swap -
                        cell+ swap !
                THEN
        REPEAT
;

: LOOP-BACK  (  loop-addr do_flag -us- )
        us> do_flag ?pairs
        us> here -  here
        !
        cell allot
;

: LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (loop)
   loop-forward loop-back
; immediate

\ : DOTEST 5 0 do 333 . loop 888 . ;
\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ;
\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ;

: +LOOP    ( -- , loop-back do_flag jump-from ?do_flag )
   compile  (+loop)
   loop-forward loop-back
; immediate

: UNLOOP ( loop-sys -r- )
        r> \ save return pointer
        rdrop rdrop
        >r
;

: RECURSE  ( ? -- ? , call the word currently being defined )
    latest compile,
; immediate

: SPACE  bl emit ;
: 0SP depth 0 ?do drop loop ;

\ : >NEWLINE ( -- , CR if needed )
\         out @ 0>
\         IF cr
\         THEN
\ ;

: 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ;
: 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ;

: DABS ( d -- |d| )
        dup 0<
        IF dnegate
        THEN
;

: S>D  ( s -- d , extend signed single precision to double )
        dup 0<
        IF -1
        ELSE 0
        THEN
;

: D>S ( d -- s ) drop ;

: PARSE-WORD ( "<spaces>name<space>" -- c-addr u ) bl parse ;
: /STRING  ( addr len n -- addr' len' ) over min rot over  + -rot - ;
: PLACE    ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ;

: ASCII ( <char> -- char, state smart )
    bl parse drop c@
    state @ 1 =
    IF [compile] literal
    ELSE
    THEN
; immediate

: CHAR    ( <char> -- char , interpret mode ) bl parse drop c@ ;
: [CHAR]  ( <char> -- char , for compile mode )
    char [compile] literal
; immediate

: $TYPE  ( $string -- ) count type ;
: 'word  ( -- addr )  here ;

: EVEN    ( addr -- addr' )   dup 1 and +  ;

: (C")  ( -- $addr ) r> dup count + aligned >r ;
: (S")  ( -- c-addr cnt ) r> count 2dup + aligned >r ;
: (.")  ( -- , type following string ) r> count 2dup + aligned >r type ;
: ",    ( addr len -- , place string into dict ) tuck 'word place 1+ allot align ;
: ,"    ( -- ) [char] " parse ", ;

: .(  ( <string> --, type string delimited by parens )
    [char] ) parse type
; immediate

: ."  ( <string> -- , type string )
    state @ 1 =
    IF compile (.")  ,"
    ELSE [char] " parse type
    THEN
; immediate

: .'   ( <string> -- , type string delimited by single quote )
        state @
        IF    compile (.")  [char] ' parse ",
        ELSE [char] ' parse type
        THEN
; immediate

: C"    ( <string> -- addr , return string address, ANSI )
        state @
        IF compile (c")   ,"
        ELSE [char] " parse pad place pad
        THEN
; immediate

: S"    ( <string> -- , -- addr , return string address, ANSI )
        state @
        IF compile (s")   ,"
        ELSE [char] " parse pad place pad count
        THEN
; immediate

: "    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate
: P"    ( <string> -- , -- addr , return string address )
        [compile] C"
; immediate

: ""  ( <string> -- addr )
       state @
       IF
               compile (C")
               bl parse-word  ",
       ELSE
               bl parse-word pad place pad
       THEN
; immediate

: SLITERAL ( addr cnt -- , compile string )
    compile (S")
    ",
; IMMEDIATE

: $APPEND ( addr count $1 -- , append text to $1 )
    over >r
        dup >r
    count +  ( -- a2 c2 end1 )
    swap cmove
    r> dup c@  ( a1 c1 )
    r> + ( -- a1 totalcount )
    swap c!
;

\ ANSI word to replace [COMPILE] and COMPILE ----------------
: POSTPONE  ( <name> -- )
	bl word find
	dup
    0= -13 ?ERROR
    0>
    IF compile,  \ immediate
    ELSE (compile)  \ normal
    THEN

; immediate

\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT  ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\    ." Begin AUTO.INIT ------" cr
;
: AUTO.TERM  ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\    ." End AUTO.TERM ------" cr
;

: INCLUDE? ( <word> <file> -- , load file if word not defined )
        bl word find
        IF drop bl word drop  ( eat word from source )
        ELSE drop include
        THEN
; immediate

: CLEARSTACK ( i*x -- )
    BEGIN depth
    WHILE drop
    REPEAT ;

variable pictured_output     \ hidden?
variable pictured_output_len \ hidden?

: <# ( -- ) pad pictured_output !  0 pictured_output_len ! ;
: #> ( -- addr n ) drop pictured_output @ pictured_output_len @ ;

: HOLD ( c -- )
    pictured_output @ dup dup 1+ pictured_output_len @ cmove c!
    1 pictured_output_len +!
;

\ ------------------------ INPUT -------------------------------

: SIGN ( n -- ) < 0 IF 45 hold THEN
;

: DIGIT ( n -- ascii )
   dup 10 < IF 48 ELSE 87 THEN + ;

: # ( n -- n )
    base @ /mod swap digit hold ;

: #S ( n -- )
    BEGIN base @ /mod dup
    WHILE swap digit hold
    REPEAT
    digit hold ;

: LWORD  ( char -- addr )
        parse-word here place here \ 00002 , use PARSE-WORD
;

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

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

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

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

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

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

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

\ : $ ( <number> -- N , convert next number as hex )
\     base @ hex
\     32 lword number? num_type_single = not
\     abort" Not a single number!"
\     swap base !
\     state @
\     IF [compile] literal
\     THEN
\ ; immediate


Added min, max, negate, abs

Added min, max, negate, abs

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

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

: .sign dup sign -1 * 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 ;