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