freebsd-nq/stand/forth/menusets.4th

\ 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

vocabulary menusets-infrastructure
only forth also menusets-infrastructure definitions

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_kernel			-> menu_kernel
	\ 	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_kernel		-> menu_kernel
	\ 	{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
;

only forth definitions also menusets-infrastructure

: 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 used appropriately 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_kernel ...
	s" set var=kernel" evaluate
	menuset-loadmenuvar

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

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

	menuset-cleanup
;

: 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=kernel"      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
;

only forth definitions

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