Added many more forth word definitions - inc. working compiler & conditionals

: (   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)
\ *********************************************************************
: CELL 1 ;
: 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 ! ;

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ cell 1- ] literal +
    [ cell 1- invert ] literal and ;
: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;
\ : ALLOT  ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
\ : C,  ( c -- ) here c! 1 chars dp +! ;
\ : W,  ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
\ : , ( n -- , lay into dictionary )  align here !  cell allot ;

\ 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 @
    IF [compile] literal
    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 ;
: ,"    ( -- ) [char] " parse ", ;

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

: ."  ( <string> -- , type string )
    state @
    IF compile (.")  ,"
    ELSE [char] " parse type
    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)
\ *********************************************************************
: CELL 1 ;
: BL 32 ;

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

: CELL+  ( x -- x+cell )  cell + ;
: CELL-  ( x -- x-cell )  cell - ;

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

: PAD ( -- addr ) here 128 + ;

: MOVE$  ( a1 n a2 -- ) swap cmove ;
: $MOVE  ( $src $dst ) over c@ 1+ cmove ;

: COUNT  dup 1 + swap c@ ;
: ON   ( addr -- , set true ) -1 swap ! ;
: OFF  ( addr -- , set false ) 0 swap ! ;

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

: EVEN-UP  ( n -- n | n+1, make even )  dup 1 and + ;
: ALIGNED  ( addr -- a-addr )
    [ cell 1- ] literal +
    [ cell 1- invert ] literal and ;
: ALIGN  ( -- , align DP ) dp @ aligned dp ! ;

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

: .( 41 parse type ; immediate

\ 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


Get rid of a manifest constant.

Get rid of a manifest constant.

\ serLE_p.fth - Polled Driver for the low-energy UART.
\ Assumes that the hardware is already setup by the launcher.
\
\ Note - The assumption here is that the LEUART is running at 9600 baud
\ The Zero Gecko can wake in 2us, and a character takes 10ms at this baud rate.
\ So we might as well WFI if the FIFO is full.

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

$8 equ LEUART_STATUS
bit4 equ LEUART_STATUS_TXBL
bit5 equ LEUART_STATUS_RXDATAV

$1C equ LEUART_RXDATA
$28 equ LEUART_TXDATA

internal

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

: (seremit)	\ char base --
\ *G Transmit a character on the given UART.
  begin
    dup LEUART_STATUS + @ LEUART_STATUS_TXBL and \ Tx FIFO full test
  until
  LEUART_TXDATA + !
;

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

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

: (serkey?)	\ base -- t/f
\ *G Return true if the given UART has a character avilable to read.
  LEUART_STATUS + @ LEUART_STATUS_RXDATAV and \ Rx FIFO
;

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

: initUART	\ divisor22 base --
  drop drop
;

external

\ ********
\ *S UART0
\ ********

useUART0? [if]

: init-ser0	;

: seremit0	\ char --
\ *G Transmit a character on UART0.
  _LEUART0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  _LEUART0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  _LEUART0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  _LEUART0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  _LEUART0 (serkey)  ;

create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line
console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

[then]

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

: init-ser	\ --
\ *G Initialise all serial ports
  [ useUART0? ] [if]  init-ser0  [then]
;

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

decimal

\ serLE_p.fth - Polled Driver for the low-energy UART.
\ Assumes that the hardware is already setup by the launcher.
\
\ Note - The assumption here is that the LEUART is running at 9600 baud
\ The Zero Gecko can wake in 2us, and a character takes 10ms at this baud rate.
\ So we might as well WFI if the FIFO is full.

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

$8 equ LEUART_STATUS
bit5 equ LEUART_STATUS_RXDATAV

$1C equ LEUART_RXDATA
$28 equ LEUART_TXDATA

internal

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

: (seremit)	\ char base --
\ *G Transmit a character on the given UART.
  begin
    dup LEUART_STATUS + @ bit4 and 		\ Tx FIFO full test
  until
  LEUART_TXDATA + !
;

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

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

: (serkey?)	\ base -- t/f
\ *G Return true if the given UART has a character avilable to read.
  LEUART_STATUS + @ LEUART_STATUS_RXDATAV and \ Rx FIFO
;

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

: initUART	\ divisor22 base --
  drop drop
;

external

\ ********
\ *S UART0
\ ********

useUART0? [if]

: init-ser0	;

: seremit0	\ char --
\ *G Transmit a character on UART0.
  _LEUART0 (seremit)  ;
: sertype0	\ c-addr len --
\ *G Transmit a string on UART0.
  _LEUART0 (sertype)  ;
: sercr0	\ --
\ *G Issue a CR/LF pair to UART0.
  _LEUART0 (sercr)  ;
: serkey?0	\ -- flag
\ *G Return true if UART0 has a character available.
  _LEUART0 (serkey?)  ;
: serkey0	\ -- char
\ *G Wait for a character on UART0.
  _LEUART0 (serkey)  ;

create Console0	\ -- addr ; OUT managed by upper driver
\ *G Generic I/O device for UART0.
  ' serkey0 ,		\ -- char ; receive char
  ' serkey?0 ,		\ -- flag ; check receive char
  ' seremit0 ,		\ -- char ; display char
  ' sertype0 ,		\ caddr len -- ; display string
  ' sercr0 ,		\ -- ; display new line
console-port 0 = [if]
  console0 constant console
\ *G *\fo{CONSOLE} is the device used by the Forth system for interaction.
\ ** It may be changed by one of the phrases of the form:
\ *C   <device>  dup opvec !  ipvec !
\ *C   <device>  SetConsole
[then]

[then]

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

: init-ser	\ --
\ *G Initialise all serial ports
  [ useUART0? ] [if]  init-ser0  [then]
;

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

decimal


Update test.4th

Update test.4th

( simple assembler/VM test - capitalize [-32] console input )
( requires assembler )

0 const u ( to upper )
1 const c ( char )

  32 u ldc,
 label &start
     c in,
 c u c sub,
     c out,
&start jump,

assemble

( simple assembler/VM test - capitalize [-32] console input )
( requires assembler )

0 const u
1 const c

  32 u ldc,
 label &start
     c in,
 c u c sub,
     c out,
&start jump,

assemble


Fix things up so it's easier to use the blocking sys calls.

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

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

target

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

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

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

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

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

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

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

\ Loop with pause until we get a non-zero result.
: (serkey-pause) pause (serkey?) ;

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

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

external

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

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

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

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

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

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

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

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

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

decimal

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

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

only forth definitions
variable cnt.pause

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

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

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

target

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

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

target

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

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

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

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

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

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

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

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

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

external

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

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

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

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

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

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

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

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

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

decimal


Do it the forth way…

Do it the forth way…

(( App Startup ))

0 value JT \ The Jumptable

\ -------------------------------------------
\ The word that sets everything up.
\ This runs before the intro banner, after
\ Init-multi.
\ -------------------------------------------
: StartApp
	hex
	init-dp @ dp ! \ Set the dictionary pointer so that we can function.
	\ I have no idea why I am doing this instead of the compilation system.

	1 getruntimelinks to jt
	." StartApp!"

	4 [ SCSSCR _SCS + ] literal  ! \ Set deepsleep

;

\ ------------------------------------------
\ Application code
\ ------------------------------------------
struct tod
 1 field h
 1 field m
 1 field s
end-struct

udata
create hms tod allot
create dhms tod allot
cdata

: +CAP ( n max -- n ) >R 1 + dup r> = if drop 0 then ;

: ADVANCE ( tod -- )
  dup s c@ #60 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #60 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #24 +cap  2dup swap h c! \ advance minutes

  2drop
;

: DADVANCE ( tod -- )
  dup s c@ #100 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #100 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #10 +cap  2dup swap h c! \ advance minutes

  2drop
;

\ ----------------------------------------------
\ Tools for writing to the LCD
\ ----------------------------------------------
: LCD#! ( n -- ) jt LCD_# @ swap call1-- ;
: LCD$! ( addr -- ) jt LCD_Wr @ swap call1-- ;

variable thecount

(( Sample code for demonstrating messages ))
: wakestart 1 $10 wakereq drop ; \ Request a wake
: wakestop  1   0 wakereq drop ; \ No more, please.

: COUNT-WORD
  wakestart
  begin
    pause
    thecount dup  @ 1+ dup lcd#! swap !
    stop
  again
;

: COUNT-WORDd
  begin
    pause self msg? if get-message drop \ We don't care who sent it.
     case
       0 of wakestop endof
       1 of wakestart endof
     endcase
     then

    thecount dup @ 1+ dup lcd#! swap !
    stop
  again
;

\ --------------------------------------------------------------------
\ Keeping time.
\ --------------------------------------------------------------------
task TOPTASK

: TOPLCDOUT hms dup h c@ #100 * swap m c@ +  lcd#! ;

: TOPWORD
  0 $10 wakereq drop \ The first Second.
  begin
   pause
   toplcdout
   hms advance
   2 $10 wakereq drop \ Relative step
  again
;

\ --------------------------------------------------------------------
\ Decimal Time
\ --------------------------------------------------------------------

task BOTTASK

: BOTWORD
  1 err interp-next wakereq drop
  begin
   pause
   dhms dadvance
   botlcd dms$ drop lcd$!
   3 err interp-next wakereq drop
  again
;

: BOTLCD dhms
  dup h c@  #10000 *
  over m c@   #100 * +
  swap s c@ + ;

\ Include the terminating null.
: dms$ base @ >R decimal s>d <# 0 hold # # $20 hold  # # $20 hold # #> R> base !  ;

: interp-next ( addr -- ) \ A fixed version.  Returns amount to step
  dup @ \ err
  #103 - dup 1 > if swap ! #13 exit then
  \ Otherwise, we need to adjust
  #125 + swap ! #14
;

: CLOCKSTART
  ['] topword toptask initiate
  ['] botword bottask initiate
;

variable err

: COUNT-DT
  0 err interp-next wakereq drop \ Don't keep the return code.
  begin
    pause
    thecount dup  @ 1 #9999 +cap dup lcd#! swap !
    2   err interp-next wakereq drop \ Don't keep the return code.
  again
;

\ ---------------------------------------------------------------
\ Setting the time.
\ ---------------------------------------------------------------

: *HMS->S  ( addr -- n ) dup h c@ #3600 * over m c@ #60 * + swap s c@ + ;
: *DHMS->S ( addr -- n ) dup h c@ #10000 * over m c@ #100 * + swap s c@ + ;

\ Stash things in the struct.
: ->*HMS ( h m s addr -- )  dup >R s c! R@ m c! R> h c! ;

: S->DS ( seconds -- seconds )
  dup #108 / #125 * \ First pass
  swap #108 mod  #125 * #108 / +
;

: DS->DHMS ( n -- h m s )
  #10000 /mod swap
    #100 /mod swap
 ;

: SETBOTH ( h m s -- )
  hms ->*hms
  hms *hms->s
  s->ds ds->dhms
  dhms ->*hms
;

((
task foo
' count-word foo initiate

))

(( App Startup ))

0 value JT \ The Jumptable

\ -------------------------------------------
\ The word that sets everything up.
\ This runs before the intro banner, after
\ Init-multi.
\ -------------------------------------------
: StartApp
	hex
	init-dp @ dp ! \ Set the dictionary pointer so that we can function.
	\ I have no idea why I am doing this instead of the compilation system.

	1 getruntimelinks to jt
	." StartApp!"

	4 [ SCSSCR _SCS + ] literal  ! \ Set deepsleep

;

\ ------------------------------------------
\ Application code
\ ------------------------------------------
struct tod
 1 field h
 1 field m
 1 field s
end-struct

udata
create hms tod allot
create dhms tod allot
cdata

: +CAP ( n max -- n ) >R 1 + dup r> = if drop 0 then ;

: ADVANCE ( tod -- )
  dup s c@ #60 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #60 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #24 +cap  2dup swap h c! \ advance minutes

  2drop
;

: DADVANCE ( tod -- )
  dup s c@ #100 +cap  2dup swap s c! \ Advance the seconds.  base n --
  if drop exit then

  dup m c@ #100 +cap  2dup swap m c! \ advance minutes
  if drop exit then

  dup h c@ #10 +cap  2dup swap h c! \ advance minutes

  2drop
;

\ ----------------------------------------------
\ Tools for writing to the LCD
\ ----------------------------------------------
: LCD#! ( n -- ) jt LCD_# @ swap call1-- ;
: LCD$! ( addr -- ) jt LCD_Wr @ swap call1-- ;

variable thecount

(( Sample code for demonstrating messages ))
: wakestart 1 $10 wakereq drop ; \ Request a wake
: wakestop  1   0 wakereq drop ; \ No more, please.

: COUNT-WORD
  wakestart
  begin
    pause
    thecount dup  @ 1+ dup lcd#! swap !
    stop
  again
;

: COUNT-WORDd
  begin
    pause self msg? if get-message drop \ We don't care who sent it.
     case
       0 of wakestop endof
       1 of wakestart endof
     endcase
     then

    thecount dup @ 1+ dup lcd#! swap !
    stop
  again
;

\ --------------------------------------------------------------------
\ Keeping time.
\ --------------------------------------------------------------------
task TOPTASK

: TOPLCDOUT hms dup h c@ #100 * swap m c@ +  lcd#! ;

: TOPWORD
  0 $10 wakereq drop \ The first Second.
  begin
   pause
   toplcdout
   hms advance
   2 $10 wakereq drop \ Relative step
  again
;

\ --------------------------------------------------------------------
\ Decimal Time
\ --------------------------------------------------------------------

task BOTTASK

: BOTWORD
  1 err interp-next wakereq drop
  begin
   pause
   dhms dadvance
   botlcd dms$ drop lcd$!
   3 err interp-next wakereq drop
  again
;

: BOTLCD dhms
  dup h c@  #10000 *
  over m c@   #100 * +
  swap s c@ + ;

\ Include the terminating null.
: dms$ base @ >R decimal s>d <# 0 hold # # $20 hold  # # $20 hold # #> R> base !  ;

: interp-next ( addr -- ) \ A fixed version.  Returns amount to step
  dup @ \ err
  #103 - dup 1 > if swap ! #13 exit then
  \ Otherwise, we need to adjust
  #125 + swap ! #14
;

: CLOCKSTART
  ['] topword toptask initiate
  ['] botword bottask initiate
;

variable err

: COUNT-DT
  0 err interp-next wakereq drop \ Don't keep the return code.
  begin
    pause
    thecount dup  @ 1 #9999 +cap dup lcd#! swap !
    2   err interp-next wakereq drop \ Don't keep the return code.
  again
;

\ ---------------------------------------------------------------
\ Setting the time.
\ ---------------------------------------------------------------

: *HMS->S  ( addr -- n ) dup h c@ #3600 * over m c@ #60 * + swap s c@ + ;
: *DHMS->S ( addr -- n ) dup h c@ #10000 * over m c@ #100 * + swap s c@ + ;

\ Stash things in the struct.
: ->*HMS ( h m s addr -- )  dup >R s c! R@ m c! R> h c! ;

: S->DS ( seconds -- seconds )
  dup #108 / #125 * \ First pass
  swap #108 mod  #125 * #108 / +
;

: DS->DHMS ( n -- h m s )
  dup #10000 / swap #10000 mod
  dup   #100 / swap   #100 mod
 ;

: SETBOTH ( h m s -- )
  hms ->*hms
  hms *hms->s
  s->ds ds->dhms
  dhms ->*hms
;

((
task foo
' count-word foo initiate

))


Fix c/p error in comment.

Fix c/p error in comment.

Approved by:	adrian (co-mentor) (implicit)

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

marker task-menusets.4th

variable menuset_use_name

create menuset_affixbuf	255 allot
create menuset_x        1   allot
create menuset_y        1   allot

: menuset-loadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}"
	else
		s" set buf=${type}set${affix}_${var}"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-loadvar
;

: menuset-unloadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadvar
;

: menuset-loadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxvar
;

: menuset-unloadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxvar
;

: menuset-loadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxvar
;

: menuset-unloadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxvar
;

: menuset-loadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-loadxvar
;

: menuset-unloadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-unloadxvar
;

: menuset-loadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}][${y}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}][${y}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxyvar
;

: menuset-unloadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxyvar
;

: menuset-loadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxyvar
;

: menuset-unloadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxyvar
;

: menuset-setnum-namevar ( N -- C-Addr/U )

	s" menuset_nameNNNNN" ( n -- n c-addr1 u1 )	\ variable basename
	drop 12 ( n c-addr1 u1 -- n c-addr1 12 )	\ remove "NNNNN"
	rot     ( n c-addr1 12 -- c-addr1 12 n )	\ move number on top

	\ convert to string
	s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )

	\ Combine strings
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over	( c-addr1 u1 c-addr2 u2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
		c@	( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
		4 pick 4 pick
			( c-addr1 u1 c-addr2 u2 c -- continued below )
			( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
			\ get destination c-addr1/u1 pair
		+	( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
			( c-addr1 u1 c-addr2 u2 c c-addr3 )
			\ combine dest-c-addr to get dest-addr for byte
		c!	( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
			( c-addr1 u1 c-addr2 u2 )
			\ store the current src-addr byte into dest-addr

		2swap 1+ 2swap	\ increment u1 in destination c-addr1/u1 pair
		swap 1+ swap	\ increment c-addr2 in source c-addr2/u2 pair
		1-		\ decrement u2 in the source c-addr2/u2 pair

		dup 0= \ time to break?
	until

	2drop	( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
		\ drop temporary number-format conversion c-addr2/u2
;

: menuset-checksetnum ( N -- )

	\
	\ adjust input to be both positive and no-higher than 65535
	\
	abs dup 65535 > if drop 65535 then ( n -- n )

	\
	\ The next few blocks will determine if we should use the default
	\ methodology (referencing the original numeric stack-input), or if-
	\ instead $menuset_name{N} has been defined wherein we would then
	\ use the value thereof as the prefix to every menu variable.
	\

	false menuset_use_name ! \ assume name is not set

	menuset-setnum-namevar
	\
	\ We now have a string that is the assembled variable name to check
	\ for... $menuset_name{N}. Let's check for it.
	\
	2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
	getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
		\ The variable is set. Let's clean up the stack leaving only
		\ its value for later use.

		true menuset_use_name !
		2swap 2drop	( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
				\ drop assembled variable name, leave the value
	else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
		\ The variable is not set. Let's clean up the stack leaving the
		\ string [portion] representing the original numeric input.

		drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
		12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
			\ truncate to original numeric stack-input
	then

	\
	\ Now, depending on whether $menuset_name{N} has been set, we have
	\ either the value thereof to be used as a prefix to all menu_*
	\ variables or we have a string representing the numeric stack-input
	\ to be used as a "set{N}" infix to the same menu_* variables.
	\
	\ For example, if the stack-input is 1 and menuset_name1 is NOT set
	\ the following variables will be referenced:
	\ 	ansiset1_caption[x]		-> ansi_caption[x]
	\ 	ansiset1_caption[x][y]		-> ansi_caption[x][y]
	\ 	menuset1_acpi			-> menu_acpi
	\ 	menuset1_caption[x]		-> menu_caption[x]
	\ 	menuset1_caption[x][y]		-> menu_caption[x][y]
	\ 	menuset1_command[x]		-> menu_command[x]
	\ 	menuset1_init			-> ``evaluated''
	\ 	menuset1_init[x]		-> menu_init[x]
	\ 	menuset1_keycode[x]		-> menu_keycode[x]
	\ 	menuset1_options		-> menu_options
	\ 	menuset1_optionstext		-> menu_optionstext
	\ 	menuset1_reboot			-> menu_reboot
	\ 	toggledset1_ansi[x]		-> toggled_ansi[x]
	\ 	toggledset1_text[x]		-> toggled_text[x]
	\ otherwise, the following variables are referenced (where {name}
	\ represents the value of $menuset_name1 (given 1 as stack-input):
	\ 	{name}ansi_caption[x]		-> ansi_caption[x]
	\ 	{name}ansi_caption[x][y]	-> ansi_caption[x][y]
	\ 	{name}menu_acpi			-> menu_acpi
	\ 	{name}menu_caption[x]		-> menu_caption[x]
	\ 	{name}menu_caption[x][y]	-> menu_caption[x][y]
	\ 	{name}menu_command[x]		-> menu_command[x]
	\ 	{name}menu_init			-> ``evaluated''
	\ 	{name}menu_init[x]		-> menu_init[x]
	\ 	{name}menu_keycode[x]		-> menu_keycode[x]
	\ 	{name}menu_options		-> menu_options
	\ 	{name}menu_optionstext		-> menu_optionstext
	\ 	{name}menu_reboot		-> menu_reboot
	\ 	{name}toggled_ansi[x]		-> toggled_ansi[x]
	\ 	{name}toggled_text[x]		-> toggled_text[x]
	\
	\ Note that menuset{N}_init and {name}menu_init are the initializers
	\ for the entire menu (for wholly dynamic menus) opposed to the per-
	\ menuitem initializers (with [x] afterward). The whole-menu init
	\ routine is evaluated and not passed down to $menu_init (which
	\ would result in double evaluation). By doing this, the initializer
	\ can initialize the menuset before we transfer it to active-duty.
	\

	\
	\ Copy our affixation (prefix or infix depending on menuset_use_name)
	\ to our buffer so that we can safely use the s-quote (s") buf again.
	\
	menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
		c@   ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
		4 pick 4 pick
		     ( c-addr1 u1 c-addr2 u2 c -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
		+    ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr3 )
		c!   ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 )
		2swap 1+ 2swap	\ increment affixbuf byte position/count
		swap 1+ swap	\ increment strbuf pointer (source c-addr2)
		1-		\ decrement strbuf byte count (source u2)
		dup 0=          \ time to break?
	until
	2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2

	\
	\ Create a variable for referencing our affix data (prefix or infix
	\ depending on menuset_use_name as described above). This variable will
	\ be temporary and only used to simplify cmdbuf assembly.
	\
	s" affix" setenv ( c-addr1 u1 -- )
;

: menuset-cleanup ( -- )
	s" type"  unsetenv
	s" var"   unsetenv
	s" x"     unsetenv
	s" y"     unsetenv
	s" affix" unsetenv
;

: menuset-loadsetnum ( N -- )

	menuset-checksetnum ( n -- )

	\
	\ From here out, we use temporary environment variables to make
	\ dealing with variable-length strings easier.
	\
	\ menuset_use_name is true or false
	\ $affix should be use appropriated w/respect to menuset_use_name
	\

	\ ... menu_init ...
	s" set var=init" evaluate
	menuset-loadmenuvar

	\ If menu_init was set by the above, evaluate it here-and-now
	\ so that the remaining variables are influenced by its actions
	s" menu_init" 2dup getenv dup -1 <> if
		2swap unsetenv \ don't want later menu-create to re-call this
		evaluate
	else
		drop 2drop ( n c-addr u -1 -- n )
	then

	[char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
	begin
		dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x

		s" set var=caption" evaluate

		\ ... menu_caption[x] ...
		menuset-loadmenuxvar

		\ ... ansi_caption[x] ...
		menuset-loadansixvar

		[char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
		begin
			dup menuset_y tuck c! 1 s" y" setenv
				\ set inner loop iterator and $y

			\ ... menu_caption[x][y] ...
			menuset-loadmenuxyvar

			\ ... ansi_caption[x][y] ...
			menuset-loadansixyvar

			1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
		until
		drop ( x y -- x )

		\ ... menu_command[x] ...
		s" set var=command" evaluate
		menuset-loadmenuxvar

		\ ... menu_init[x] ...
		s" set var=init" evaluate
		menuset-loadmenuxvar

		\ ... menu_keycode[x] ...
		s" set var=keycode" evaluate
		menuset-loadmenuxvar

		\ ... toggled_text[x] ...
		s" set var=text" evaluate
		menuset-loadtoggledxvar

		\ ... toggled_ansi[x] ...
		s" set var=ansi" evaluate
		menuset-loadtoggledxvar

		1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
		                             \ continue if less than 57
	until
	drop ( x -- ) \ loop iterator

	\ ... menu_reboot ...
	s" set var=reboot" evaluate
	menuset-loadmenuvar

	\ ... menu_acpi ...
	s" set var=acpi" evaluate
	menuset-loadmenuvar

	\ ... menu_options ...
	s" set var=options" evaluate
	menuset-loadmenuvar

	\ ... menu_optionstext ...
	s" set var=optionstext" evaluate
	menuset-loadmenuvar

	menuset-cleanup
;

: menuset-loadinitial ( -- )
	s" menuset_initial" getenv dup -1 <> if
		?number 0<> if
			menuset-loadsetnum
		then
	else
		drop \ cruft
	then
;

: menusets-unset ( -- )

	s" menuset_initial" unsetenv

	1 begin
		dup menuset-checksetnum ( n n -- n )

		dup menuset-setnum-namevar ( n n -- n )
		unsetenv

		\ If the current menuset does not populate the first menuitem,
		\ we stop completely.

		menuset_use_name @ true = if
			s" set buf=${affix}menu_caption[1]"
		else
			s" set buf=menuset${affix}_caption[1]"
		then
		evaluate s" buf" getenv getenv -1 = if
			drop ( n -- )
			s" buf" unsetenv
			menuset-cleanup
			exit
		else
			drop ( n c-addr2 -- n ) \ unused
		then

		[char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
		begin
			dup menuset_x tuck c! 1 s" x" setenv \ set $x to x

			s" set var=caption" evaluate
			menuset-unloadmenuxvar
			menuset-unloadmenuxvar
			menuset-unloadansixvar
			[char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
			begin
				dup menuset_y tuck c! 1 s" y" setenv
					\ sets $y to y
				menuset-unloadmenuxyvar
				menuset-unloadansixyvar
				1+ dup 57 > ( n x y -- n x y' 0|-1 )
			until
			drop ( n x y -- n x )
			s" set var=command" evaluate menuset-unloadmenuxvar
			s" set var=init"    evaluate menuset-unloadmenuxvar
			s" set var=keycode" evaluate menuset-unloadmenuxvar
			s" set var=text"    evaluate menuset-unloadtoggledxvar
			s" set var=ansi"    evaluate menuset-unloadtoggledxvar

			1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
		until
		drop ( n x -- n ) \ loop iterator

		s" set var=acpi"        evaluate menuset-unloadmenuvar
		s" set var=init"        evaluate menuset-unloadmenuvar
		s" set var=options"     evaluate menuset-unloadmenuvar
		s" set var=optionstext" evaluate menuset-unloadmenuvar
		s" set var=reboot"      evaluate menuset-unloadmenuvar

		1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
	until
	drop ( n' -- ) \ loop iterator

	s" buf" unsetenv
	menuset-cleanup
;

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

marker task-menusets.4th

variable menuset_use_name

create menuset_affixbuf	255 allot
create menuset_x        1   allot
create menuset_y        1   allot

: menuset-loadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}"
	else
		s" set buf=${type}set${affix}_${var}"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-loadvar
;

: menuset-unloadmenuvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadvar
;

: menuset-loadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxvar
;

: menuset-unloadansixvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxvar
;

: menuset-loadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxvar
;

: menuset-unloadmenuxvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxvar
;

: menuset-loadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-loadxvar
;

: menuset-unloadtoggledxvar ( -- )
	s" set type=toggled" evaluate
	menuset-unloadxvar
;

: menuset-loadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
	menuset_use_name @ true = if
		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	else
		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
		( u1 -- u1 c-addr2 u2 )
	then
	evaluate ( u1 c-addr2 u2 -- u1 )
	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
	rot 2 pick 2 pick over + -rot + tuck -
		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
		\ Generate a string representing rvalue inheritance var
	getenv dup -1 = if
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
		\ NOT set -- clean up the stack
		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
		2drop ( c-addr2 u2 -- )
	else
		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
		evaluate ( c-addr2 u2 -- )
	then

	s" cmdbuf" unsetenv
;

: menuset-unloadxyvar ( -- )

	\ menuset_use_name is true or false
	\ $type should be set to one of:
	\ 	menu toggled ansi
	\ $var should be set to one of:
	\ 	caption command keycode text ...
	\ $x is "1" through "8"
	\ $y is "0" through "9"
	\ $affix is either prefix (menuset_use_name is true)
	\               or infix (menuset_use_name is false)

	menuset_use_name @ true = if
		s" set buf=${affix}${type}_${var}[${x}][${y}]"
	else
		s" set buf=${type}set${affix}_${var}[${x}][${y}]"
	then
	evaluate
	s" buf" getenv unsetenv
	s" buf" unsetenv
;

: menuset-loadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-loadxyvar
;

: menuset-unloadansixyvar ( -- )
	s" set type=ansi" evaluate
	menuset-unloadxyvar
;

: menuset-loadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-loadxyvar
;

: menuset-unloadmenuxyvar ( -- )
	s" set type=menu" evaluate
	menuset-unloadxyvar
;

: menuset-setnum-namevar ( N -- C-Addr/U )

	s" menuset_nameNNNNN" ( n -- n c-addr1 u1 )	\ variable basename
	drop 12 ( n c-addr1 u1 -- n c-addr1 12 )	\ remove "NNNNN"
	rot     ( n c-addr1 12 -- c-addr1 12 n )	\ move number on top

	\ convert to string
	s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )

	\ Combine strings
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over	( c-addr1 u1 c-addr2 u2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
		c@	( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
			( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
		4 pick 4 pick
			( c-addr1 u1 c-addr2 u2 c -- continued below )
			( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
			\ get destination c-addr1/u1 pair
		+	( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
			( c-addr1 u1 c-addr2 u2 c c-addr3 )
			\ combine dest-c-addr to get dest-addr for byte
		c!	( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
			( c-addr1 u1 c-addr2 u2 )
			\ store the current src-addr byte into dest-addr

		2swap 1+ 2swap	\ increment u1 in destination c-addr1/u1 pair
		swap 1+ swap	\ increment c-addr2 in source c-addr2/u2 pair
		1-		\ decrement u2 in the source c-addr2/u2 pair

		dup 0= \ time to break?
	until

	2drop	( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
		\ drop temporary number-format conversion c-addr2/u2
;

: menuset-checksetnum ( N -- )

	\
	\ adjust input to be both positive and no-higher than 65535
	\
	abs dup 65535 > if drop 65535 then ( n -- n )

	\
	\ The next few blocks will determine if we should use the default
	\ methodology (referencing the original numeric stack-input), or if-
	\ instead $menuset_name{N} has been defined wherein we would then
	\ use the value thereof as the prefix to every menu variable.
	\

	false menuset_use_name ! \ assume name is not set

	menuset-setnum-namevar
	\
	\ We now have a string that is the assembled variable name to check
	\ for... $menuset_name{N}. Let's check for it.
	\
	2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
	getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
		\ The variable is set. Let's clean up the stack leaving only
		\ its value for later use.

		true menuset_use_name !
		2swap 2drop	( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
				\ drop assembled variable name, leave the value
	else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
		\ The variable is not set. Let's clean up the stack leaving the
		\ string [portion] representing the original numeric input.

		drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
		12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
			\ truncate to original numeric stack-input
	then

	\
	\ Now, depending on whether $menuset_name{N} has been set, we have
	\ either the value thereof to be used as a prefix to all menu_*
	\ variables or we have a string representing the numeric stack-input
	\ to be used as a "set{N}" infix to the same menu_* variables.
	\
	\ For example, if the stack-input is 1 and menuset_name1 is NOT set
	\ the following variables will be referenced:
	\ 	ansiset1_caption[x]		-> ansi_caption[x]
	\ 	ansiset1_caption[x][y]		-> ansi_caption[x][y]
	\ 	menuset1_acpi			-> menu_acpi
	\ 	menuset1_caption[x]		-> menu_caption[x]
	\ 	menuset1_caption[x][y]		-> menu_caption[x][y]
	\ 	menuset1_command[x]		-> menu_command[x]
	\ 	menuset1_init			-> ``evaluated''
	\ 	menuset1_init[x]		-> menu_init[x]
	\ 	menuset1_keycode[x]		-> menu_keycode[x]
	\ 	menuset1_options		-> menu_options
	\ 	menuset1_optionstext		-> menu_optionstext
	\ 	menuset1_reboot			-> menu_reboot
	\ 	toggledset1_ansi[x]		-> toggled_ansi[x]
	\ 	toggledset1_text[x]		-> toggled_text[x]
	\ otherwise, the following variables are referenced (where {name}
	\ represents the value of $menuset_name1 (given 1 as stack-input):
	\ 	{name}ansi_caption[x]		-> ansi_caption[x]
	\ 	{name}ansi_caption[x][y]	-> ansi_caption[x][y]
	\ 	{name}menu_acpi			-> menu_acpi
	\ 	{name}menu_caption[x]		-> menu_caption[x]
	\ 	{name}menu_caption[x][y]	-> menu_caption[x][y]
	\ 	{name}menu_command[x]		-> menu_command[x]
	\ 	{name}menu_init			-> ``evaluated''
	\ 	{name}menu_init[x]		-> menu_init[x]
	\ 	{name}menu_keycode[x]		-> menu_keycode[x]
	\ 	{name}menu_options		-> menu_options
	\ 	{name}menu_optionstext		-> menu_optionstext
	\ 	{name}menu_reboot		-> menu_reboot
	\ 	{name}toggled_ansi[x]		-> toggled_ansi[x]
	\ 	{name}toggled_text[x]		-> toggled_text[x]
	\
	\ Note that menuset{N}_init and {name}menu_init are the initializers
	\ for the entire menu (for wholly dynamic menus) opposed to the per-
	\ menuitem initializers (with [x] afterward). The whole-menu init
	\ routine is evaluated and not passed down to $menu_init (which
	\ would result in double evaluation). By doing this, the initializer
	\ can initialize the menuset before we transfer it to active-duty.
	\

	\
	\ Copy our affixation (prefix or infix depending on menuset_use_name)
	\ to our buffer so that we can safely use the s-quote (s") buf again.
	\
	menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
		over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
		c@   ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
		4 pick 4 pick
		     ( c-addr1 u1 c-addr2 u2 c -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
		+    ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 c c-addr3 )
		c!   ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
		     ( c-addr1 u1 c-addr2 u2 )
		2swap 1+ 2swap	\ increment affixbuf byte position/count
		swap 1+ swap	\ increment strbuf pointer (source c-addr2)
		1-		\ decrement strbuf byte count (source u2)
		dup 0=          \ time to break?
	until
	2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2

	\
	\ Create a variable for referencing our affix data (prefix or infix
	\ depending on menuset_use_name as described above). This variable will
	\ be temporary and only used to simplify cmdbuf assembly.
	\
	s" affix" setenv ( c-addr1 u1 -- )
;

: menuset-cleanup ( -- )
	s" type"  unsetenv
	s" var"   unsetenv
	s" x"     unsetenv
	s" y"     unsetenv
	s" affix" unsetenv
;

: menuset-loadsetnum ( N -- )

	menuset-checksetnum ( n -- )

	\
	\ From here out, we use temporary environment variables to make
	\ dealing with variable-length strings easier.
	\
	\ menuset_use_name is true or false
	\ $affix should be use appropriated w/respect to menuset_use_name
	\

	\ ... menu_init ...
	s" set var=init" evaluate
	menuset-loadmenuvar

	\ If menu_init was set by the above, evaluate it here-and-now
	\ so that the remaining variables are influenced by its actions
	s" menu_init" 2dup getenv dup -1 <> if
		2swap unsetenv \ don't want later menu-create to re-call this
		evaluate
	else
		drop 2drop ( n c-addr u -1 -- n )
	then

	[char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
	begin
		dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x

		s" set var=caption" evaluate

		\ ... menu_caption[x] ...
		menuset-loadmenuxvar

		\ ... ansi_caption[x] ...
		menuset-loadansixvar

		[char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
		begin
			dup menuset_y tuck c! 1 s" y" setenv
				\ set inner loop iterator and $y

			\ ... menu_caption[x][y] ...
			menuset-loadmenuxyvar

			\ ... ansi_caption[x][y] ...
			menuset-loadansixyvar

			1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
		until
		drop ( x y -- x )

		\ ... menu_command[x] ...
		s" set var=command" evaluate
		menuset-loadmenuxvar

		\ ... menu_init[x] ...
		s" set var=init" evaluate
		menuset-loadmenuxvar

		\ ... menu_keycode[x] ...
		s" set var=keycode" evaluate
		menuset-loadmenuxvar

		\ ... toggled_text[x] ...
		s" set var=text" evaluate
		menuset-loadtoggledxvar

		\ ... toggled_ansi[x] ...
		s" set var=ansi" evaluate
		menuset-loadtoggledxvar

		1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
		                             \ continue if less than 57
	until
	drop ( x -- ) \ loop iterator

	\ ... menu_reboot ...
	s" set var=reboot" evaluate
	menuset-loadmenuvar

	\ ... menu_acpi ...
	s" set var=acpi" evaluate
	menuset-loadmenuvar

	\ ... menu_options ...
	s" set var=options" evaluate
	menuset-loadmenuvar

	\ ... menu_options ...
	s" set var=optionstext" evaluate
	menuset-loadmenuvar

	menuset-cleanup
;

: menuset-loadinitial ( -- )
	s" menuset_initial" getenv dup -1 <> if
		?number 0<> if
			menuset-loadsetnum
		then
	else
		drop \ cruft
	then
;

: menusets-unset ( -- )

	s" menuset_initial" unsetenv

	1 begin
		dup menuset-checksetnum ( n n -- n )

		dup menuset-setnum-namevar ( n n -- n )
		unsetenv

		\ If the current menuset does not populate the first menuitem,
		\ we stop completely.

		menuset_use_name @ true = if
			s" set buf=${affix}menu_caption[1]"
		else
			s" set buf=menuset${affix}_caption[1]"
		then
		evaluate s" buf" getenv getenv -1 = if
			drop ( n -- )
			s" buf" unsetenv
			menuset-cleanup
			exit
		else
			drop ( n c-addr2 -- n ) \ unused
		then

		[char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
		begin
			dup menuset_x tuck c! 1 s" x" setenv \ set $x to x

			s" set var=caption" evaluate
			menuset-unloadmenuxvar
			menuset-unloadmenuxvar
			menuset-unloadansixvar
			[char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
			begin
				dup menuset_y tuck c! 1 s" y" setenv
					\ sets $y to y
				menuset-unloadmenuxyvar
				menuset-unloadansixyvar
				1+ dup 57 > ( n x y -- n x y' 0|-1 )
			until
			drop ( n x y -- n x )
			s" set var=command" evaluate menuset-unloadmenuxvar
			s" set var=init"    evaluate menuset-unloadmenuxvar
			s" set var=keycode" evaluate menuset-unloadmenuxvar
			s" set var=text"    evaluate menuset-unloadtoggledxvar
			s" set var=ansi"    evaluate menuset-unloadtoggledxvar

			1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
		until
		drop ( n x -- n ) \ loop iterator

		s" set var=acpi"        evaluate menuset-unloadmenuvar
		s" set var=init"        evaluate menuset-unloadmenuvar
		s" set var=options"     evaluate menuset-unloadmenuvar
		s" set var=optionstext" evaluate menuset-unloadmenuvar
		s" set var=reboot"      evaluate menuset-unloadmenuvar

		1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
	until
	drop ( n' -- ) \ loop iterator

	s" buf" unsetenv
	menuset-cleanup
;