xref: /titanic_52/usr/src/boot/sys/boot/forth/menusets.4th (revision c417cb1befd4cb39f40f4e6ae4c7d3068a45f877)
14a5d661aSToomas Soome\ Copyright (c) 2012 Devin Teske <dteske@FreeBSD.org>
24a5d661aSToomas Soome\ All rights reserved.
34a5d661aSToomas Soome\
44a5d661aSToomas Soome\ Redistribution and use in source and binary forms, with or without
54a5d661aSToomas Soome\ modification, are permitted provided that the following conditions
64a5d661aSToomas Soome\ are met:
74a5d661aSToomas Soome\ 1. Redistributions of source code must retain the above copyright
84a5d661aSToomas Soome\    notice, this list of conditions and the following disclaimer.
94a5d661aSToomas Soome\ 2. Redistributions in binary form must reproduce the above copyright
104a5d661aSToomas Soome\    notice, this list of conditions and the following disclaimer in the
114a5d661aSToomas Soome\    documentation and/or other materials provided with the distribution.
124a5d661aSToomas Soome\
134a5d661aSToomas Soome\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
144a5d661aSToomas Soome\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
154a5d661aSToomas Soome\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
164a5d661aSToomas Soome\ ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
174a5d661aSToomas Soome\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
184a5d661aSToomas Soome\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
194a5d661aSToomas Soome\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
204a5d661aSToomas Soome\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
214a5d661aSToomas Soome\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
224a5d661aSToomas Soome\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
234a5d661aSToomas Soome\ SUCH DAMAGE.
244a5d661aSToomas Soome\
254a5d661aSToomas Soome
264a5d661aSToomas Soomemarker task-menusets.4th
274a5d661aSToomas Soome
284a5d661aSToomas Soomevocabulary menusets-infrastructure
294a5d661aSToomas Soomeonly forth also menusets-infrastructure definitions
304a5d661aSToomas Soome
314a5d661aSToomas Soomevariable menuset_use_name
324a5d661aSToomas Soome
334a5d661aSToomas Soomecreate menuset_affixbuf	255 allot
344a5d661aSToomas Soomecreate menuset_x        1   allot
354a5d661aSToomas Soomecreate menuset_y        1   allot
364a5d661aSToomas Soome
374a5d661aSToomas Soome: menuset-loadvar ( -- )
384a5d661aSToomas Soome
394a5d661aSToomas Soome	\ menuset_use_name is true or false
404a5d661aSToomas Soome	\ $type should be set to one of:
414a5d661aSToomas Soome	\ 	menu toggled ansi
424a5d661aSToomas Soome	\ $var should be set to one of:
434a5d661aSToomas Soome	\ 	caption command keycode text ...
444a5d661aSToomas Soome	\ $affix is either prefix (menuset_use_name is true)
454a5d661aSToomas Soome	\               or infix (menuset_use_name is false)
464a5d661aSToomas Soome
474a5d661aSToomas Soome	s" set cmdbuf='set ${type}_${var}=\$'" evaluate
484a5d661aSToomas Soome	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
494a5d661aSToomas Soome	menuset_use_name @ true = if
504a5d661aSToomas Soome		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}"
514a5d661aSToomas Soome		( u1 -- u1 c-addr2 u2 )
524a5d661aSToomas Soome	else
534a5d661aSToomas Soome		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}"
544a5d661aSToomas Soome		( u1 -- u1 c-addr2 u2 )
554a5d661aSToomas Soome	then
564a5d661aSToomas Soome	evaluate ( u1 c-addr2 u2 -- u1 )
574a5d661aSToomas Soome	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
584a5d661aSToomas Soome	rot 2 pick 2 pick over + -rot + tuck -
594a5d661aSToomas Soome		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
604a5d661aSToomas Soome		\ Generate a string representing rvalue inheritance var
614a5d661aSToomas Soome	getenv dup -1 = if
624a5d661aSToomas Soome		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
634a5d661aSToomas Soome		\ NOT set -- clean up the stack
644a5d661aSToomas Soome		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
654a5d661aSToomas Soome		2drop ( c-addr2 u2 -- )
664a5d661aSToomas Soome	else
674a5d661aSToomas Soome		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
684a5d661aSToomas Soome		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
694a5d661aSToomas Soome		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
704a5d661aSToomas Soome		evaluate ( c-addr2 u2 -- )
714a5d661aSToomas Soome	then
724a5d661aSToomas Soome
734a5d661aSToomas Soome	s" cmdbuf" unsetenv
744a5d661aSToomas Soome;
754a5d661aSToomas Soome
764a5d661aSToomas Soome: menuset-unloadvar ( -- )
774a5d661aSToomas Soome
784a5d661aSToomas Soome	\ menuset_use_name is true or false
794a5d661aSToomas Soome	\ $type should be set to one of:
804a5d661aSToomas Soome	\ 	menu toggled ansi
814a5d661aSToomas Soome	\ $var should be set to one of:
824a5d661aSToomas Soome	\ 	caption command keycode text ...
834a5d661aSToomas Soome	\ $affix is either prefix (menuset_use_name is true)
844a5d661aSToomas Soome	\               or infix (menuset_use_name is false)
854a5d661aSToomas Soome
864a5d661aSToomas Soome	menuset_use_name @ true = if
874a5d661aSToomas Soome		s" set buf=${affix}${type}_${var}"
884a5d661aSToomas Soome	else
894a5d661aSToomas Soome		s" set buf=${type}set${affix}_${var}"
904a5d661aSToomas Soome	then
914a5d661aSToomas Soome	evaluate
924a5d661aSToomas Soome	s" buf" getenv unsetenv
934a5d661aSToomas Soome	s" buf" unsetenv
944a5d661aSToomas Soome;
954a5d661aSToomas Soome
964a5d661aSToomas Soome: menuset-loadmenuvar ( -- )
974a5d661aSToomas Soome	s" set type=menu" evaluate
984a5d661aSToomas Soome	menuset-loadvar
994a5d661aSToomas Soome;
1004a5d661aSToomas Soome
1014a5d661aSToomas Soome: menuset-unloadmenuvar ( -- )
1024a5d661aSToomas Soome	s" set type=menu" evaluate
1034a5d661aSToomas Soome	menuset-unloadvar
1044a5d661aSToomas Soome;
1054a5d661aSToomas Soome
1064a5d661aSToomas Soome: menuset-loadxvar ( -- )
1074a5d661aSToomas Soome
1084a5d661aSToomas Soome	\ menuset_use_name is true or false
1094a5d661aSToomas Soome	\ $type should be set to one of:
1104a5d661aSToomas Soome	\ 	menu toggled ansi
1114a5d661aSToomas Soome	\ $var should be set to one of:
1124a5d661aSToomas Soome	\ 	caption command keycode text ...
1134a5d661aSToomas Soome	\ $x is "1" through "8"
1144a5d661aSToomas Soome	\ $affix is either prefix (menuset_use_name is true)
1154a5d661aSToomas Soome	\               or infix (menuset_use_name is false)
1164a5d661aSToomas Soome
1174a5d661aSToomas Soome	s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate
1184a5d661aSToomas Soome	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
1194a5d661aSToomas Soome	menuset_use_name @ true = if
1204a5d661aSToomas Soome		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]"
1214a5d661aSToomas Soome		( u1 -- u1 c-addr2 u2 )
1224a5d661aSToomas Soome	else
1234a5d661aSToomas Soome		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]"
1244a5d661aSToomas Soome		( u1 -- u1 c-addr2 u2 )
1254a5d661aSToomas Soome	then
1264a5d661aSToomas Soome	evaluate ( u1 c-addr2 u2 -- u1 )
1274a5d661aSToomas Soome	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
1284a5d661aSToomas Soome	rot 2 pick 2 pick over + -rot + tuck -
1294a5d661aSToomas Soome		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
1304a5d661aSToomas Soome		\ Generate a string representing rvalue inheritance var
1314a5d661aSToomas Soome	getenv dup -1 = if
1324a5d661aSToomas Soome		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
1334a5d661aSToomas Soome		\ NOT set -- clean up the stack
1344a5d661aSToomas Soome		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
1354a5d661aSToomas Soome		2drop ( c-addr2 u2 -- )
1364a5d661aSToomas Soome	else
1374a5d661aSToomas Soome		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
1384a5d661aSToomas Soome		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
1394a5d661aSToomas Soome		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
1404a5d661aSToomas Soome		evaluate ( c-addr2 u2 -- )
1414a5d661aSToomas Soome	then
1424a5d661aSToomas Soome
1434a5d661aSToomas Soome	s" cmdbuf" unsetenv
1444a5d661aSToomas Soome;
1454a5d661aSToomas Soome
1464a5d661aSToomas Soome: menuset-unloadxvar ( -- )
1474a5d661aSToomas Soome
1484a5d661aSToomas Soome	\ menuset_use_name is true or false
1494a5d661aSToomas Soome	\ $type should be set to one of:
1504a5d661aSToomas Soome	\ 	menu toggled ansi
1514a5d661aSToomas Soome	\ $var should be set to one of:
1524a5d661aSToomas Soome	\ 	caption command keycode text ...
1534a5d661aSToomas Soome	\ $x is "1" through "8"
1544a5d661aSToomas Soome	\ $affix is either prefix (menuset_use_name is true)
1554a5d661aSToomas Soome	\               or infix (menuset_use_name is false)
1564a5d661aSToomas Soome
1574a5d661aSToomas Soome	menuset_use_name @ true = if
1584a5d661aSToomas Soome		s" set buf=${affix}${type}_${var}[${x}]"
1594a5d661aSToomas Soome	else
1604a5d661aSToomas Soome		s" set buf=${type}set${affix}_${var}[${x}]"
1614a5d661aSToomas Soome	then
1624a5d661aSToomas Soome	evaluate
1634a5d661aSToomas Soome	s" buf" getenv unsetenv
1644a5d661aSToomas Soome	s" buf" unsetenv
1654a5d661aSToomas Soome;
1664a5d661aSToomas Soome
1674a5d661aSToomas Soome: menuset-loadansixvar ( -- )
1684a5d661aSToomas Soome	s" set type=ansi" evaluate
1694a5d661aSToomas Soome	menuset-loadxvar
1704a5d661aSToomas Soome;
1714a5d661aSToomas Soome
1724a5d661aSToomas Soome: menuset-unloadansixvar ( -- )
1734a5d661aSToomas Soome	s" set type=ansi" evaluate
1744a5d661aSToomas Soome	menuset-unloadxvar
1754a5d661aSToomas Soome;
1764a5d661aSToomas Soome
1774a5d661aSToomas Soome: menuset-loadmenuxvar ( -- )
1784a5d661aSToomas Soome	s" set type=menu" evaluate
1794a5d661aSToomas Soome	menuset-loadxvar
1804a5d661aSToomas Soome;
1814a5d661aSToomas Soome
1824a5d661aSToomas Soome: menuset-unloadmenuxvar ( -- )
1834a5d661aSToomas Soome	s" set type=menu" evaluate
1844a5d661aSToomas Soome	menuset-unloadxvar
1854a5d661aSToomas Soome;
1864a5d661aSToomas Soome
187*c417cb1bSToomas Soome: menuset-unloadtypelessxvar ( -- )
188*c417cb1bSToomas Soome	s" set type=" evaluate
189*c417cb1bSToomas Soome	menuset-unloadxvar
190*c417cb1bSToomas Soome;
191*c417cb1bSToomas Soome
1924a5d661aSToomas Soome: menuset-loadtoggledxvar ( -- )
1934a5d661aSToomas Soome	s" set type=toggled" evaluate
1944a5d661aSToomas Soome	menuset-loadxvar
1954a5d661aSToomas Soome;
1964a5d661aSToomas Soome
1974a5d661aSToomas Soome: menuset-unloadtoggledxvar ( -- )
1984a5d661aSToomas Soome	s" set type=toggled" evaluate
1994a5d661aSToomas Soome	menuset-unloadxvar
2004a5d661aSToomas Soome;
2014a5d661aSToomas Soome
2024a5d661aSToomas Soome: menuset-loadxyvar ( -- )
2034a5d661aSToomas Soome
2044a5d661aSToomas Soome	\ menuset_use_name is true or false
2054a5d661aSToomas Soome	\ $type should be set to one of:
2064a5d661aSToomas Soome	\ 	menu toggled ansi
2074a5d661aSToomas Soome	\ $var should be set to one of:
2084a5d661aSToomas Soome	\ 	caption command keycode text ...
2094a5d661aSToomas Soome	\ $x is "1" through "8"
2104a5d661aSToomas Soome	\ $y is "0" through "9"
2114a5d661aSToomas Soome	\ $affix is either prefix (menuset_use_name is true)
2124a5d661aSToomas Soome	\               or infix (menuset_use_name is false)
2134a5d661aSToomas Soome
2144a5d661aSToomas Soome	s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate
2154a5d661aSToomas Soome	s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length
2164a5d661aSToomas Soome	menuset_use_name @ true = if
2174a5d661aSToomas Soome		s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]"
2184a5d661aSToomas Soome		( u1 -- u1 c-addr2 u2 )
2194a5d661aSToomas Soome	else
2204a5d661aSToomas Soome		s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]"
2214a5d661aSToomas Soome		( u1 -- u1 c-addr2 u2 )
2224a5d661aSToomas Soome	then
2234a5d661aSToomas Soome	evaluate ( u1 c-addr2 u2 -- u1 )
2244a5d661aSToomas Soome	s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 )
2254a5d661aSToomas Soome	rot 2 pick 2 pick over + -rot + tuck -
2264a5d661aSToomas Soome		( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 )
2274a5d661aSToomas Soome		\ Generate a string representing rvalue inheritance var
2284a5d661aSToomas Soome	getenv dup -1 = if
2294a5d661aSToomas Soome		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 )
2304a5d661aSToomas Soome		\ NOT set -- clean up the stack
2314a5d661aSToomas Soome		drop ( c-addr2 u2 -1 -- c-addr2 u2 )
2324a5d661aSToomas Soome		2drop ( c-addr2 u2 -- )
2334a5d661aSToomas Soome	else
2344a5d661aSToomas Soome		( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 )
2354a5d661aSToomas Soome		\ SET -- execute cmdbuf (c-addr2/u2) to inherit value
2364a5d661aSToomas Soome		2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 )
2374a5d661aSToomas Soome		evaluate ( c-addr2 u2 -- )
2384a5d661aSToomas Soome	then
2394a5d661aSToomas Soome
2404a5d661aSToomas Soome	s" cmdbuf" unsetenv
2414a5d661aSToomas Soome;
2424a5d661aSToomas Soome
2434a5d661aSToomas Soome: menuset-unloadxyvar ( -- )
2444a5d661aSToomas Soome
2454a5d661aSToomas Soome	\ menuset_use_name is true or false
2464a5d661aSToomas Soome	\ $type should be set to one of:
2474a5d661aSToomas Soome	\ 	menu toggled ansi
2484a5d661aSToomas Soome	\ $var should be set to one of:
2494a5d661aSToomas Soome	\ 	caption command keycode text ...
2504a5d661aSToomas Soome	\ $x is "1" through "8"
2514a5d661aSToomas Soome	\ $y is "0" through "9"
2524a5d661aSToomas Soome	\ $affix is either prefix (menuset_use_name is true)
2534a5d661aSToomas Soome	\               or infix (menuset_use_name is false)
2544a5d661aSToomas Soome
2554a5d661aSToomas Soome	menuset_use_name @ true = if
2564a5d661aSToomas Soome		s" set buf=${affix}${type}_${var}[${x}][${y}]"
2574a5d661aSToomas Soome	else
2584a5d661aSToomas Soome		s" set buf=${type}set${affix}_${var}[${x}][${y}]"
2594a5d661aSToomas Soome	then
2604a5d661aSToomas Soome	evaluate
2614a5d661aSToomas Soome	s" buf" getenv unsetenv
2624a5d661aSToomas Soome	s" buf" unsetenv
2634a5d661aSToomas Soome;
2644a5d661aSToomas Soome
2654a5d661aSToomas Soome: menuset-loadansixyvar ( -- )
2664a5d661aSToomas Soome	s" set type=ansi" evaluate
2674a5d661aSToomas Soome	menuset-loadxyvar
2684a5d661aSToomas Soome;
2694a5d661aSToomas Soome
2704a5d661aSToomas Soome: menuset-unloadansixyvar ( -- )
2714a5d661aSToomas Soome	s" set type=ansi" evaluate
2724a5d661aSToomas Soome	menuset-unloadxyvar
2734a5d661aSToomas Soome;
2744a5d661aSToomas Soome
2754a5d661aSToomas Soome: menuset-loadmenuxyvar ( -- )
2764a5d661aSToomas Soome	s" set type=menu" evaluate
2774a5d661aSToomas Soome	menuset-loadxyvar
2784a5d661aSToomas Soome;
2794a5d661aSToomas Soome
2804a5d661aSToomas Soome: menuset-unloadmenuxyvar ( -- )
2814a5d661aSToomas Soome	s" set type=menu" evaluate
2824a5d661aSToomas Soome	menuset-unloadxyvar
2834a5d661aSToomas Soome;
2844a5d661aSToomas Soome
2854a5d661aSToomas Soome: menuset-setnum-namevar ( N -- C-Addr/U )
2864a5d661aSToomas Soome
2874a5d661aSToomas Soome	s" menuset_nameNNNNN" ( n -- n c-addr1 u1 )	\ variable basename
2884a5d661aSToomas Soome	drop 12 ( n c-addr1 u1 -- n c-addr1 12 )	\ remove "NNNNN"
2894a5d661aSToomas Soome	rot     ( n c-addr1 12 -- c-addr1 12 n )	\ move number on top
2904a5d661aSToomas Soome
2914a5d661aSToomas Soome	\ convert to string
2924a5d661aSToomas Soome	s>d <# #s #> ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 )
2934a5d661aSToomas Soome
2944a5d661aSToomas Soome	\ Combine strings
2954a5d661aSToomas Soome	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
2964a5d661aSToomas Soome		over	( c-addr1 u1 c-addr2 u2 -- continued below )
2974a5d661aSToomas Soome			( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr
2984a5d661aSToomas Soome		c@	( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below )
2994a5d661aSToomas Soome			( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte
3004a5d661aSToomas Soome		4 pick 4 pick
3014a5d661aSToomas Soome			( c-addr1 u1 c-addr2 u2 c -- continued below )
3024a5d661aSToomas Soome			( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
3034a5d661aSToomas Soome			\ get destination c-addr1/u1 pair
3044a5d661aSToomas Soome		+	( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below )
3054a5d661aSToomas Soome			( c-addr1 u1 c-addr2 u2 c c-addr3 )
3064a5d661aSToomas Soome			\ combine dest-c-addr to get dest-addr for byte
3074a5d661aSToomas Soome		c!	( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
3084a5d661aSToomas Soome			( c-addr1 u1 c-addr2 u2 )
3094a5d661aSToomas Soome			\ store the current src-addr byte into dest-addr
3104a5d661aSToomas Soome
3114a5d661aSToomas Soome		2swap 1+ 2swap	\ increment u1 in destination c-addr1/u1 pair
3124a5d661aSToomas Soome		swap 1+ swap	\ increment c-addr2 in source c-addr2/u2 pair
3134a5d661aSToomas Soome		1-		\ decrement u2 in the source c-addr2/u2 pair
3144a5d661aSToomas Soome
3154a5d661aSToomas Soome		dup 0= \ time to break?
3164a5d661aSToomas Soome	until
3174a5d661aSToomas Soome
3184a5d661aSToomas Soome	2drop	( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 )
3194a5d661aSToomas Soome		\ drop temporary number-format conversion c-addr2/u2
3204a5d661aSToomas Soome;
3214a5d661aSToomas Soome
3224a5d661aSToomas Soome: menuset-checksetnum ( N -- )
3234a5d661aSToomas Soome
3244a5d661aSToomas Soome	\
3254a5d661aSToomas Soome	\ adjust input to be both positive and no-higher than 65535
3264a5d661aSToomas Soome	\
3274a5d661aSToomas Soome	abs dup 65535 > if drop 65535 then ( n -- n )
3284a5d661aSToomas Soome
3294a5d661aSToomas Soome	\
3304a5d661aSToomas Soome	\ The next few blocks will determine if we should use the default
3314a5d661aSToomas Soome	\ methodology (referencing the original numeric stack-input), or if-
3324a5d661aSToomas Soome	\ instead $menuset_name{N} has been defined wherein we would then
3334a5d661aSToomas Soome	\ use the value thereof as the prefix to every menu variable.
3344a5d661aSToomas Soome	\
3354a5d661aSToomas Soome
3364a5d661aSToomas Soome	false menuset_use_name ! \ assume name is not set
3374a5d661aSToomas Soome
3384a5d661aSToomas Soome	menuset-setnum-namevar
3394a5d661aSToomas Soome	\
3404a5d661aSToomas Soome	\ We now have a string that is the assembled variable name to check
3414a5d661aSToomas Soome	\ for... $menuset_name{N}. Let's check for it.
3424a5d661aSToomas Soome	\
3434a5d661aSToomas Soome	2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy
3444a5d661aSToomas Soome	getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
3454a5d661aSToomas Soome		\ The variable is set. Let's clean up the stack leaving only
3464a5d661aSToomas Soome		\ its value for later use.
3474a5d661aSToomas Soome
3484a5d661aSToomas Soome		true menuset_use_name !
3494a5d661aSToomas Soome		2swap 2drop	( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 )
3504a5d661aSToomas Soome				\ drop assembled variable name, leave the value
3514a5d661aSToomas Soome	else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable
3524a5d661aSToomas Soome		\ The variable is not set. Let's clean up the stack leaving the
3534a5d661aSToomas Soome		\ string [portion] representing the original numeric input.
3544a5d661aSToomas Soome
3554a5d661aSToomas Soome		drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result
3564a5d661aSToomas Soome		12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 )
3574a5d661aSToomas Soome			\ truncate to original numeric stack-input
3584a5d661aSToomas Soome	then
3594a5d661aSToomas Soome
3604a5d661aSToomas Soome	\
3614a5d661aSToomas Soome	\ Now, depending on whether $menuset_name{N} has been set, we have
3624a5d661aSToomas Soome	\ either the value thereof to be used as a prefix to all menu_*
3634a5d661aSToomas Soome	\ variables or we have a string representing the numeric stack-input
3644a5d661aSToomas Soome	\ to be used as a "set{N}" infix to the same menu_* variables.
3654a5d661aSToomas Soome	\
3664a5d661aSToomas Soome	\ For example, if the stack-input is 1 and menuset_name1 is NOT set
3674a5d661aSToomas Soome	\ the following variables will be referenced:
3684a5d661aSToomas Soome	\ 	ansiset1_caption[x]		-> ansi_caption[x]
3694a5d661aSToomas Soome	\ 	ansiset1_caption[x][y]		-> ansi_caption[x][y]
3704a5d661aSToomas Soome	\ 	menuset1_acpi			-> menu_acpi
3714a5d661aSToomas Soome	\ 	menuset1_osconsole		-> menu_osconsole
3724a5d661aSToomas Soome	\ 	menuset1_caption[x]		-> menu_caption[x]
3734a5d661aSToomas Soome	\ 	menuset1_caption[x][y]		-> menu_caption[x][y]
3744a5d661aSToomas Soome	\ 	menuset1_command[x]		-> menu_command[x]
3754a5d661aSToomas Soome	\ 	menuset1_init			-> ``evaluated''
3764a5d661aSToomas Soome	\ 	menuset1_init[x]		-> menu_init[x]
3774a5d661aSToomas Soome	\ 	menuset1_kernel			-> menu_kernel
3784a5d661aSToomas Soome	\ 	menuset1_keycode[x]		-> menu_keycode[x]
3794a5d661aSToomas Soome	\ 	menuset1_options		-> menu_options
3804a5d661aSToomas Soome	\ 	menuset1_optionstext		-> menu_optionstext
3814a5d661aSToomas Soome	\ 	menuset1_reboot			-> menu_reboot
3824a5d661aSToomas Soome	\ 	toggledset1_ansi[x]		-> toggled_ansi[x]
3834a5d661aSToomas Soome	\ 	toggledset1_text[x]		-> toggled_text[x]
3844a5d661aSToomas Soome	\ otherwise, the following variables are referenced (where {name}
3854a5d661aSToomas Soome	\ represents the value of $menuset_name1 (given 1 as stack-input):
3864a5d661aSToomas Soome	\ 	{name}ansi_caption[x]		-> ansi_caption[x]
3874a5d661aSToomas Soome	\ 	{name}ansi_caption[x][y]	-> ansi_caption[x][y]
3884a5d661aSToomas Soome	\ 	{name}menu_acpi			-> menu_acpi
3894a5d661aSToomas Soome	\ 	{name}menu_caption[x]		-> menu_caption[x]
3904a5d661aSToomas Soome	\ 	{name}menu_caption[x][y]	-> menu_caption[x][y]
3914a5d661aSToomas Soome	\ 	{name}menu_command[x]		-> menu_command[x]
3924a5d661aSToomas Soome	\ 	{name}menu_init			-> ``evaluated''
3934a5d661aSToomas Soome	\ 	{name}menu_init[x]		-> menu_init[x]
3944a5d661aSToomas Soome	\ 	{name}menu_kernel		-> menu_kernel
3954a5d661aSToomas Soome	\ 	{name}menu_keycode[x]		-> menu_keycode[x]
3964a5d661aSToomas Soome	\ 	{name}menu_options		-> menu_options
3974a5d661aSToomas Soome	\ 	{name}menu_optionstext		-> menu_optionstext
3984a5d661aSToomas Soome	\ 	{name}menu_reboot		-> menu_reboot
3994a5d661aSToomas Soome	\ 	{name}toggled_ansi[x]		-> toggled_ansi[x]
4004a5d661aSToomas Soome	\ 	{name}toggled_text[x]		-> toggled_text[x]
4014a5d661aSToomas Soome	\
4024a5d661aSToomas Soome	\ Note that menuset{N}_init and {name}menu_init are the initializers
4034a5d661aSToomas Soome	\ for the entire menu (for wholly dynamic menus) opposed to the per-
4044a5d661aSToomas Soome	\ menuitem initializers (with [x] afterward). The whole-menu init
4054a5d661aSToomas Soome	\ routine is evaluated and not passed down to $menu_init (which
4064a5d661aSToomas Soome	\ would result in double evaluation). By doing this, the initializer
4074a5d661aSToomas Soome	\ can initialize the menuset before we transfer it to active-duty.
4084a5d661aSToomas Soome	\
4094a5d661aSToomas Soome
4104a5d661aSToomas Soome	\
4114a5d661aSToomas Soome	\ Copy our affixation (prefix or infix depending on menuset_use_name)
4124a5d661aSToomas Soome	\ to our buffer so that we can safely use the s-quote (s") buf again.
4134a5d661aSToomas Soome	\
4144a5d661aSToomas Soome	menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 )
4154a5d661aSToomas Soome	begin ( using u2 in c-addr2/u2 pair as countdown to zero )
4164a5d661aSToomas Soome		over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 )
4174a5d661aSToomas Soome		c@   ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c )
4184a5d661aSToomas Soome		4 pick 4 pick
4194a5d661aSToomas Soome		     ( c-addr1 u1 c-addr2 u2 c -- continued below )
4204a5d661aSToomas Soome		     ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 )
4214a5d661aSToomas Soome		+    ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below )
4224a5d661aSToomas Soome		     ( c-addr1 u1 c-addr2 u2 c c-addr3 )
4234a5d661aSToomas Soome		c!   ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below )
4244a5d661aSToomas Soome		     ( c-addr1 u1 c-addr2 u2 )
4254a5d661aSToomas Soome		2swap 1+ 2swap	\ increment affixbuf byte position/count
4264a5d661aSToomas Soome		swap 1+ swap	\ increment strbuf pointer (source c-addr2)
4274a5d661aSToomas Soome		1-		\ decrement strbuf byte count (source u2)
4284a5d661aSToomas Soome		dup 0=          \ time to break?
4294a5d661aSToomas Soome	until
4304a5d661aSToomas Soome	2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2
4314a5d661aSToomas Soome
4324a5d661aSToomas Soome	\
4334a5d661aSToomas Soome	\ Create a variable for referencing our affix data (prefix or infix
4344a5d661aSToomas Soome	\ depending on menuset_use_name as described above). This variable will
4354a5d661aSToomas Soome	\ be temporary and only used to simplify cmdbuf assembly.
4364a5d661aSToomas Soome	\
4374a5d661aSToomas Soome	s" affix" setenv ( c-addr1 u1 -- )
4384a5d661aSToomas Soome;
4394a5d661aSToomas Soome
4404a5d661aSToomas Soome: menuset-cleanup ( -- )
4414a5d661aSToomas Soome	s" type"  unsetenv
4424a5d661aSToomas Soome	s" var"   unsetenv
4434a5d661aSToomas Soome	s" x"     unsetenv
4444a5d661aSToomas Soome	s" y"     unsetenv
4454a5d661aSToomas Soome	s" affix" unsetenv
4464a5d661aSToomas Soome;
4474a5d661aSToomas Soome
4484a5d661aSToomas Soomeonly forth definitions also menusets-infrastructure
4494a5d661aSToomas Soome
4504a5d661aSToomas Soome: menuset-loadsetnum ( N -- )
4514a5d661aSToomas Soome
4524a5d661aSToomas Soome	menuset-checksetnum ( n -- )
4534a5d661aSToomas Soome
4544a5d661aSToomas Soome	\
4554a5d661aSToomas Soome	\ From here out, we use temporary environment variables to make
4564a5d661aSToomas Soome	\ dealing with variable-length strings easier.
4574a5d661aSToomas Soome	\
4584a5d661aSToomas Soome	\ menuset_use_name is true or false
4594a5d661aSToomas Soome	\ $affix should be used appropriately w/respect to menuset_use_name
4604a5d661aSToomas Soome	\
4614a5d661aSToomas Soome
4624a5d661aSToomas Soome	\ ... menu_init ...
4634a5d661aSToomas Soome	s" set var=init" evaluate
4644a5d661aSToomas Soome	menuset-loadmenuvar
4654a5d661aSToomas Soome
4664a5d661aSToomas Soome	\ If menu_init was set by the above, evaluate it here-and-now
4674a5d661aSToomas Soome	\ so that the remaining variables are influenced by its actions
4684a5d661aSToomas Soome	s" menu_init" 2dup getenv dup -1 <> if
4694a5d661aSToomas Soome		2swap unsetenv \ don't want later menu-create to re-call this
4704a5d661aSToomas Soome		evaluate
4714a5d661aSToomas Soome	else
4724a5d661aSToomas Soome		drop 2drop ( n c-addr u -1 -- n )
4734a5d661aSToomas Soome	then
4744a5d661aSToomas Soome
4754a5d661aSToomas Soome	[char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56)
4764a5d661aSToomas Soome	begin
4774a5d661aSToomas Soome		dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x
4784a5d661aSToomas Soome
4794a5d661aSToomas Soome		s" set var=caption" evaluate
4804a5d661aSToomas Soome
4814a5d661aSToomas Soome		\ ... menu_caption[x] ...
4824a5d661aSToomas Soome		menuset-loadmenuxvar
4834a5d661aSToomas Soome
4844a5d661aSToomas Soome		\ ... ansi_caption[x] ...
4854a5d661aSToomas Soome		menuset-loadansixvar
4864a5d661aSToomas Soome
4874a5d661aSToomas Soome		[char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57)
4884a5d661aSToomas Soome		begin
4894a5d661aSToomas Soome			dup menuset_y tuck c! 1 s" y" setenv
4904a5d661aSToomas Soome				\ set inner loop iterator and $y
4914a5d661aSToomas Soome
4924a5d661aSToomas Soome			\ ... menu_caption[x][y] ...
4934a5d661aSToomas Soome			menuset-loadmenuxyvar
4944a5d661aSToomas Soome
4954a5d661aSToomas Soome			\ ... ansi_caption[x][y] ...
4964a5d661aSToomas Soome			menuset-loadansixyvar
4974a5d661aSToomas Soome
4984a5d661aSToomas Soome			1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test
4994a5d661aSToomas Soome		until
5004a5d661aSToomas Soome		drop ( x y -- x )
5014a5d661aSToomas Soome
5024a5d661aSToomas Soome		\ ... menu_command[x] ...
5034a5d661aSToomas Soome		s" set var=command" evaluate
5044a5d661aSToomas Soome		menuset-loadmenuxvar
5054a5d661aSToomas Soome
5064a5d661aSToomas Soome		\ ... menu_init[x] ...
5074a5d661aSToomas Soome		s" set var=init" evaluate
5084a5d661aSToomas Soome		menuset-loadmenuxvar
5094a5d661aSToomas Soome
5104a5d661aSToomas Soome		\ ... menu_keycode[x] ...
5114a5d661aSToomas Soome		s" set var=keycode" evaluate
5124a5d661aSToomas Soome		menuset-loadmenuxvar
5134a5d661aSToomas Soome
5144a5d661aSToomas Soome		\ ... toggled_text[x] ...
5154a5d661aSToomas Soome		s" set var=text" evaluate
5164a5d661aSToomas Soome		menuset-loadtoggledxvar
5174a5d661aSToomas Soome
5184a5d661aSToomas Soome		\ ... toggled_ansi[x] ...
5194a5d661aSToomas Soome		s" set var=ansi" evaluate
5204a5d661aSToomas Soome		menuset-loadtoggledxvar
5214a5d661aSToomas Soome
5224a5d661aSToomas Soome		1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator
5234a5d661aSToomas Soome		                             \ continue if less than 57
5244a5d661aSToomas Soome	until
5254a5d661aSToomas Soome	drop ( x -- ) \ loop iterator
5264a5d661aSToomas Soome
5274a5d661aSToomas Soome	\ ... menu_reboot ...
5284a5d661aSToomas Soome	s" set var=reboot" evaluate
5294a5d661aSToomas Soome	menuset-loadmenuvar
5304a5d661aSToomas Soome
5314a5d661aSToomas Soome	\ ... menu_acpi ...
5324a5d661aSToomas Soome	s" set var=acpi" evaluate
5334a5d661aSToomas Soome	menuset-loadmenuvar
5344a5d661aSToomas Soome
5354a5d661aSToomas Soome	\ ... menu_osconsole ...
5364a5d661aSToomas Soome	s" set var=osconsole" evaluate
5374a5d661aSToomas Soome	menuset-loadmenuvar
5384a5d661aSToomas Soome
5394a5d661aSToomas Soome	\ ... menu_kernel ...
5404a5d661aSToomas Soome	s" set var=kernel" evaluate
5414a5d661aSToomas Soome	menuset-loadmenuvar
5424a5d661aSToomas Soome
5434a5d661aSToomas Soome	\ ... menu_options ...
5444a5d661aSToomas Soome	s" set var=options" evaluate
5454a5d661aSToomas Soome	menuset-loadmenuvar
5464a5d661aSToomas Soome
5474a5d661aSToomas Soome	\ ... menu_optionstext ...
5484a5d661aSToomas Soome	s" set var=optionstext" evaluate
5494a5d661aSToomas Soome	menuset-loadmenuvar
5504a5d661aSToomas Soome
5514a5d661aSToomas Soome	menuset-cleanup
5524a5d661aSToomas Soome;
5534a5d661aSToomas Soome
5544a5d661aSToomas Soome: menusets-unset ( -- )
5554a5d661aSToomas Soome
556*c417cb1bSToomas Soome	\ clean up BE menu internal variables
557*c417cb1bSToomas Soome	s" beansi_bootfs"    unsetenv
558*c417cb1bSToomas Soome	s" beansi_current"   unsetenv
559*c417cb1bSToomas Soome	s" beansi_page"      unsetenv
560*c417cb1bSToomas Soome	s" beansi_pageof"    unsetenv
561*c417cb1bSToomas Soome	s" bemenu_bootfs"    unsetenv
562*c417cb1bSToomas Soome	s" bemenu_current"   unsetenv
563*c417cb1bSToomas Soome	s" bemenu_page"      unsetenv
564*c417cb1bSToomas Soome	s" bemenu_pageof"    unsetenv
565*c417cb1bSToomas Soome	s" zfs_be_active"    unsetenv
566*c417cb1bSToomas Soome	s" zfs_be_currpage"  unsetenv
567*c417cb1bSToomas Soome	s" zfs_be_pages"     unsetenv
568*c417cb1bSToomas Soome
5694a5d661aSToomas Soome	s" menuset_initial"  unsetenv
5704a5d661aSToomas Soome
5714a5d661aSToomas Soome	1 begin
5724a5d661aSToomas Soome		dup menuset-checksetnum ( n n -- n )
5734a5d661aSToomas Soome
5744a5d661aSToomas Soome		dup menuset-setnum-namevar ( n n -- n )
5754a5d661aSToomas Soome		unsetenv
5764a5d661aSToomas Soome
5774a5d661aSToomas Soome		\ If the current menuset does not populate the first menuitem,
5784a5d661aSToomas Soome		\ we stop completely.
5794a5d661aSToomas Soome
5804a5d661aSToomas Soome		menuset_use_name @ true = if
581*c417cb1bSToomas Soome			s" set buf=${affix}menu_command[1]"
5824a5d661aSToomas Soome		else
583*c417cb1bSToomas Soome			s" set buf=menuset${affix}_command[1]"
5844a5d661aSToomas Soome		then
5854a5d661aSToomas Soome		evaluate s" buf" getenv getenv -1 = if
5864a5d661aSToomas Soome			drop ( n -- )
5874a5d661aSToomas Soome			s" buf" unsetenv
5884a5d661aSToomas Soome			menuset-cleanup
5894a5d661aSToomas Soome			exit
5904a5d661aSToomas Soome		else
5914a5d661aSToomas Soome			drop ( n c-addr2 -- n ) \ unused
5924a5d661aSToomas Soome		then
5934a5d661aSToomas Soome
5944a5d661aSToomas Soome		[char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56)
5954a5d661aSToomas Soome		begin
5964a5d661aSToomas Soome			dup menuset_x tuck c! 1 s" x" setenv \ set $x to x
5974a5d661aSToomas Soome
5984a5d661aSToomas Soome			s" set var=caption" evaluate
5994a5d661aSToomas Soome			menuset-unloadmenuxvar
6004a5d661aSToomas Soome			menuset-unloadmenuxvar
6014a5d661aSToomas Soome			menuset-unloadansixvar
6024a5d661aSToomas Soome			[char] 0 ( n x -- n x y ) \ Inner loop '0' to '9'
6034a5d661aSToomas Soome			begin
6044a5d661aSToomas Soome				dup menuset_y tuck c! 1 s" y" setenv
6054a5d661aSToomas Soome					\ sets $y to y
6064a5d661aSToomas Soome				menuset-unloadmenuxyvar
6074a5d661aSToomas Soome				menuset-unloadansixyvar
6084a5d661aSToomas Soome				1+ dup 57 > ( n x y -- n x y' 0|-1 )
6094a5d661aSToomas Soome			until
6104a5d661aSToomas Soome			drop ( n x y -- n x )
6114a5d661aSToomas Soome			s" set var=command" evaluate menuset-unloadmenuxvar
6124a5d661aSToomas Soome			s" set var=init"    evaluate menuset-unloadmenuxvar
6134a5d661aSToomas Soome			s" set var=keycode" evaluate menuset-unloadmenuxvar
614*c417cb1bSToomas Soome			s" set var=root"    evaluate menuset-unloadtypelessxvar
6154a5d661aSToomas Soome			s" set var=text"    evaluate menuset-unloadtoggledxvar
6164a5d661aSToomas Soome			s" set var=ansi"    evaluate menuset-unloadtoggledxvar
6174a5d661aSToomas Soome
6184a5d661aSToomas Soome			1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test
6194a5d661aSToomas Soome		until
6204a5d661aSToomas Soome		drop ( n x -- n ) \ loop iterator
6214a5d661aSToomas Soome
6224a5d661aSToomas Soome		s" set var=acpi"        evaluate menuset-unloadmenuvar
6234a5d661aSToomas Soome		s" set var=osconsole"   evaluate menuset-unloadmenuvar
6244a5d661aSToomas Soome		s" set var=init"        evaluate menuset-unloadmenuvar
6254a5d661aSToomas Soome		s" set var=kernel"      evaluate menuset-unloadmenuvar
6264a5d661aSToomas Soome		s" set var=options"     evaluate menuset-unloadmenuvar
6274a5d661aSToomas Soome		s" set var=optionstext" evaluate menuset-unloadmenuvar
6284a5d661aSToomas Soome		s" set var=reboot"      evaluate menuset-unloadmenuvar
6294a5d661aSToomas Soome
6304a5d661aSToomas Soome		1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test
6314a5d661aSToomas Soome	until
6324a5d661aSToomas Soome	drop ( n' -- ) \ loop iterator
6334a5d661aSToomas Soome
6344a5d661aSToomas Soome	s" buf" unsetenv
6354a5d661aSToomas Soome	menuset-cleanup
6364a5d661aSToomas Soome;
6374a5d661aSToomas Soome
6384a5d661aSToomas Soomeonly forth definitions
6394a5d661aSToomas Soome
6404a5d661aSToomas Soome: menuset-loadinitial ( -- )
6414a5d661aSToomas Soome	s" menuset_initial" getenv dup -1 <> if
6424a5d661aSToomas Soome		?number 0<> if
6434a5d661aSToomas Soome			menuset-loadsetnum
6444a5d661aSToomas Soome		then
6454a5d661aSToomas Soome	else
6464a5d661aSToomas Soome		drop \ cruft
6474a5d661aSToomas Soome	then
6484a5d661aSToomas Soome;
649