1*22028508SToomas Soome\ Copyright (c) 2012 Devin Teske <dteske@FreeBSD.org> 2*22028508SToomas Soome\ Copyright 2020 OmniOS Community Edition (OmniOSce) Association. 3*22028508SToomas Soome\ All rights reserved. 4*22028508SToomas Soome\ 5*22028508SToomas Soome\ Redistribution and use in source and binary forms, with or without 6*22028508SToomas Soome\ modification, are permitted provided that the following conditions 7*22028508SToomas Soome\ are met: 8*22028508SToomas Soome\ 1. Redistributions of source code must retain the above copyright 9*22028508SToomas Soome\ notice, this list of conditions and the following disclaimer. 10*22028508SToomas Soome\ 2. Redistributions in binary form must reproduce the above copyright 11*22028508SToomas Soome\ notice, this list of conditions and the following disclaimer in the 12*22028508SToomas Soome\ documentation and/or other materials provided with the distribution. 13*22028508SToomas Soome\ 14*22028508SToomas Soome\ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15*22028508SToomas Soome\ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16*22028508SToomas Soome\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17*22028508SToomas Soome\ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18*22028508SToomas Soome\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19*22028508SToomas Soome\ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20*22028508SToomas Soome\ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21*22028508SToomas Soome\ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22*22028508SToomas Soome\ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23*22028508SToomas Soome\ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24*22028508SToomas Soome\ SUCH DAMAGE. 25*22028508SToomas Soome\ 26*22028508SToomas Soome 27*22028508SToomas Soomemarker task-menusets.4th 28*22028508SToomas Soome 29*22028508SToomas Soomevocabulary menusets-infrastructure 30*22028508SToomas Soomeonly forth also menusets-infrastructure definitions 31*22028508SToomas Soome 32*22028508SToomas Soomevariable menuset_use_name 33*22028508SToomas Soome 34*22028508SToomas Soomecreate menuset_affixbuf 255 allot 35*22028508SToomas Soomecreate menuset_x 1 allot 36*22028508SToomas Soomecreate menuset_y 1 allot 37*22028508SToomas Soome 38*22028508SToomas Soome: menuset-loadvar ( -- ) 39*22028508SToomas Soome 40*22028508SToomas Soome \ menuset_use_name is true or false 41*22028508SToomas Soome \ $type should be set to one of: 42*22028508SToomas Soome \ menu toggled ansi 43*22028508SToomas Soome \ $var should be set to one of: 44*22028508SToomas Soome \ caption command keycode text ... 45*22028508SToomas Soome \ $affix is either prefix (menuset_use_name is true) 46*22028508SToomas Soome \ or infix (menuset_use_name is false) 47*22028508SToomas Soome 48*22028508SToomas Soome s" set cmdbuf='set ${type}_${var}=\$'" evaluate 49*22028508SToomas Soome s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length 50*22028508SToomas Soome menuset_use_name @ true = if 51*22028508SToomas Soome s" set cmdbuf=${cmdbuf}${affix}${type}_${var}" 52*22028508SToomas Soome ( u1 -- u1 c-addr2 u2 ) 53*22028508SToomas Soome else 54*22028508SToomas Soome s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}" 55*22028508SToomas Soome ( u1 -- u1 c-addr2 u2 ) 56*22028508SToomas Soome then 57*22028508SToomas Soome evaluate ( u1 c-addr2 u2 -- u1 ) 58*22028508SToomas Soome s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 ) 59*22028508SToomas Soome rot 2 pick 2 pick over + -rot + tuck - 60*22028508SToomas Soome ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 ) 61*22028508SToomas Soome \ Generate a string representing rvalue inheritance var 62*22028508SToomas Soome getenv dup -1 = if 63*22028508SToomas Soome ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 ) 64*22028508SToomas Soome \ NOT set -- clean up the stack 65*22028508SToomas Soome drop ( c-addr2 u2 -1 -- c-addr2 u2 ) 66*22028508SToomas Soome 2drop ( c-addr2 u2 -- ) 67*22028508SToomas Soome else 68*22028508SToomas Soome ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 ) 69*22028508SToomas Soome \ SET -- execute cmdbuf (c-addr2/u2) to inherit value 70*22028508SToomas Soome 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 ) 71*22028508SToomas Soome evaluate ( c-addr2 u2 -- ) 72*22028508SToomas Soome then 73*22028508SToomas Soome 74*22028508SToomas Soome s" cmdbuf" unsetenv 75*22028508SToomas Soome; 76*22028508SToomas Soome 77*22028508SToomas Soome: menuset-unloadvar ( -- ) 78*22028508SToomas Soome 79*22028508SToomas Soome \ menuset_use_name is true or false 80*22028508SToomas Soome \ $type should be set to one of: 81*22028508SToomas Soome \ menu toggled ansi 82*22028508SToomas Soome \ $var should be set to one of: 83*22028508SToomas Soome \ caption command keycode text ... 84*22028508SToomas Soome \ $affix is either prefix (menuset_use_name is true) 85*22028508SToomas Soome \ or infix (menuset_use_name is false) 86*22028508SToomas Soome 87*22028508SToomas Soome menuset_use_name @ true = if 88*22028508SToomas Soome s" set buf=${affix}${type}_${var}" 89*22028508SToomas Soome else 90*22028508SToomas Soome s" set buf=${type}set${affix}_${var}" 91*22028508SToomas Soome then 92*22028508SToomas Soome evaluate 93*22028508SToomas Soome s" buf" getenv unsetenv 94*22028508SToomas Soome s" buf" unsetenv 95*22028508SToomas Soome; 96*22028508SToomas Soome 97*22028508SToomas Soome: menuset-loadmenuvar ( -- ) 98*22028508SToomas Soome s" set type=menu" evaluate 99*22028508SToomas Soome menuset-loadvar 100*22028508SToomas Soome; 101*22028508SToomas Soome 102*22028508SToomas Soome: menuset-unloadmenuvar ( -- ) 103*22028508SToomas Soome s" set type=menu" evaluate 104*22028508SToomas Soome menuset-unloadvar 105*22028508SToomas Soome; 106*22028508SToomas Soome 107*22028508SToomas Soome: menuset-loadxvar ( -- ) 108*22028508SToomas Soome 109*22028508SToomas Soome \ menuset_use_name is true or false 110*22028508SToomas Soome \ $type should be set to one of: 111*22028508SToomas Soome \ menu toggled ansi 112*22028508SToomas Soome \ $var should be set to one of: 113*22028508SToomas Soome \ caption command keycode text ... 114*22028508SToomas Soome \ $x is "1" through "8" 115*22028508SToomas Soome \ $affix is either prefix (menuset_use_name is true) 116*22028508SToomas Soome \ or infix (menuset_use_name is false) 117*22028508SToomas Soome 118*22028508SToomas Soome s" set cmdbuf='set ${type}_${var}[${x}]=\$'" evaluate 119*22028508SToomas Soome s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length 120*22028508SToomas Soome menuset_use_name @ true = if 121*22028508SToomas Soome s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}]" 122*22028508SToomas Soome ( u1 -- u1 c-addr2 u2 ) 123*22028508SToomas Soome else 124*22028508SToomas Soome s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}]" 125*22028508SToomas Soome ( u1 -- u1 c-addr2 u2 ) 126*22028508SToomas Soome then 127*22028508SToomas Soome evaluate ( u1 c-addr2 u2 -- u1 ) 128*22028508SToomas Soome s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 ) 129*22028508SToomas Soome rot 2 pick 2 pick over + -rot + tuck - 130*22028508SToomas Soome ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 ) 131*22028508SToomas Soome \ Generate a string representing rvalue inheritance var 132*22028508SToomas Soome getenv dup -1 = if 133*22028508SToomas Soome ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 ) 134*22028508SToomas Soome \ NOT set -- clean up the stack 135*22028508SToomas Soome drop ( c-addr2 u2 -1 -- c-addr2 u2 ) 136*22028508SToomas Soome 2drop ( c-addr2 u2 -- ) 137*22028508SToomas Soome else 138*22028508SToomas Soome ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 ) 139*22028508SToomas Soome \ SET -- execute cmdbuf (c-addr2/u2) to inherit value 140*22028508SToomas Soome 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 ) 141*22028508SToomas Soome evaluate ( c-addr2 u2 -- ) 142*22028508SToomas Soome then 143*22028508SToomas Soome 144*22028508SToomas Soome s" cmdbuf" unsetenv 145*22028508SToomas Soome; 146*22028508SToomas Soome 147*22028508SToomas Soome: menuset-unloadxvar ( -- ) 148*22028508SToomas Soome 149*22028508SToomas Soome \ menuset_use_name is true or false 150*22028508SToomas Soome \ $type should be set to one of: 151*22028508SToomas Soome \ menu toggled ansi 152*22028508SToomas Soome \ $var should be set to one of: 153*22028508SToomas Soome \ caption command keycode text ... 154*22028508SToomas Soome \ $x is "1" through "8" 155*22028508SToomas Soome \ $affix is either prefix (menuset_use_name is true) 156*22028508SToomas Soome \ or infix (menuset_use_name is false) 157*22028508SToomas Soome 158*22028508SToomas Soome menuset_use_name @ true = if 159*22028508SToomas Soome s" set buf=${affix}${type}_${var}[${x}]" 160*22028508SToomas Soome else 161*22028508SToomas Soome s" set buf=${type}set${affix}_${var}[${x}]" 162*22028508SToomas Soome then 163*22028508SToomas Soome evaluate 164*22028508SToomas Soome s" buf" getenv unsetenv 165*22028508SToomas Soome s" buf" unsetenv 166*22028508SToomas Soome; 167*22028508SToomas Soome 168*22028508SToomas Soome: menuset-loadansixvar ( -- ) 169*22028508SToomas Soome s" set type=ansi" evaluate 170*22028508SToomas Soome menuset-loadxvar 171*22028508SToomas Soome; 172*22028508SToomas Soome 173*22028508SToomas Soome: menuset-unloadansixvar ( -- ) 174*22028508SToomas Soome s" set type=ansi" evaluate 175*22028508SToomas Soome menuset-unloadxvar 176*22028508SToomas Soome; 177*22028508SToomas Soome 178*22028508SToomas Soome: menuset-loadmenuxvar ( -- ) 179*22028508SToomas Soome s" set type=menu" evaluate 180*22028508SToomas Soome menuset-loadxvar 181*22028508SToomas Soome; 182*22028508SToomas Soome 183*22028508SToomas Soome: menuset-unloadmenuxvar ( -- ) 184*22028508SToomas Soome s" set type=menu" evaluate 185*22028508SToomas Soome menuset-unloadxvar 186*22028508SToomas Soome; 187*22028508SToomas Soome 188*22028508SToomas Soome: menuset-unloadtypelessxvar ( -- ) 189*22028508SToomas Soome s" set type=" evaluate 190*22028508SToomas Soome menuset-unloadxvar 191*22028508SToomas Soome; 192*22028508SToomas Soome 193*22028508SToomas Soome: menuset-loadtoggledxvar ( -- ) 194*22028508SToomas Soome s" set type=toggled" evaluate 195*22028508SToomas Soome menuset-loadxvar 196*22028508SToomas Soome; 197*22028508SToomas Soome 198*22028508SToomas Soome: menuset-unloadtoggledxvar ( -- ) 199*22028508SToomas Soome s" set type=toggled" evaluate 200*22028508SToomas Soome menuset-unloadxvar 201*22028508SToomas Soome; 202*22028508SToomas Soome 203*22028508SToomas Soome: menuset-loadxyvar ( -- ) 204*22028508SToomas Soome 205*22028508SToomas Soome \ menuset_use_name is true or false 206*22028508SToomas Soome \ $type should be set to one of: 207*22028508SToomas Soome \ menu toggled ansi 208*22028508SToomas Soome \ $var should be set to one of: 209*22028508SToomas Soome \ caption command keycode text ... 210*22028508SToomas Soome \ $x is "1" through "8" 211*22028508SToomas Soome \ $y is "0" through "9" 212*22028508SToomas Soome \ $affix is either prefix (menuset_use_name is true) 213*22028508SToomas Soome \ or infix (menuset_use_name is false) 214*22028508SToomas Soome 215*22028508SToomas Soome s" set cmdbuf='set ${type}_${var}[${x}][${y}]=\$'" evaluate 216*22028508SToomas Soome s" cmdbuf" getenv swap drop ( -- u1 ) \ get string length 217*22028508SToomas Soome menuset_use_name @ true = if 218*22028508SToomas Soome s" set cmdbuf=${cmdbuf}${affix}${type}_${var}[${x}][${y}]" 219*22028508SToomas Soome ( u1 -- u1 c-addr2 u2 ) 220*22028508SToomas Soome else 221*22028508SToomas Soome s" set cmdbuf=${cmdbuf}${type}set${affix}_${var}[${x}][${y}]" 222*22028508SToomas Soome ( u1 -- u1 c-addr2 u2 ) 223*22028508SToomas Soome then 224*22028508SToomas Soome evaluate ( u1 c-addr2 u2 -- u1 ) 225*22028508SToomas Soome s" cmdbuf" getenv ( u1 -- u1 c-addr2 u2 ) 226*22028508SToomas Soome rot 2 pick 2 pick over + -rot + tuck - 227*22028508SToomas Soome ( u1 c-addr2 u2 -- c-addr2 u2 c-addr1 u1 ) 228*22028508SToomas Soome \ Generate a string representing rvalue inheritance var 229*22028508SToomas Soome getenv dup -1 = if 230*22028508SToomas Soome ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 -1 ) 231*22028508SToomas Soome \ NOT set -- clean up the stack 232*22028508SToomas Soome drop ( c-addr2 u2 -1 -- c-addr2 u2 ) 233*22028508SToomas Soome 2drop ( c-addr2 u2 -- ) 234*22028508SToomas Soome else 235*22028508SToomas Soome ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 c-addr1 u1 ) 236*22028508SToomas Soome \ SET -- execute cmdbuf (c-addr2/u2) to inherit value 237*22028508SToomas Soome 2drop ( c-addr2 u2 c-addr1 u1 -- c-addr2 u2 ) 238*22028508SToomas Soome evaluate ( c-addr2 u2 -- ) 239*22028508SToomas Soome then 240*22028508SToomas Soome 241*22028508SToomas Soome s" cmdbuf" unsetenv 242*22028508SToomas Soome; 243*22028508SToomas Soome 244*22028508SToomas Soome: menuset-unloadxyvar ( -- ) 245*22028508SToomas Soome 246*22028508SToomas Soome \ menuset_use_name is true or false 247*22028508SToomas Soome \ $type should be set to one of: 248*22028508SToomas Soome \ menu toggled ansi 249*22028508SToomas Soome \ $var should be set to one of: 250*22028508SToomas Soome \ caption command keycode text ... 251*22028508SToomas Soome \ $x is "1" through "8" 252*22028508SToomas Soome \ $y is "0" through "9" 253*22028508SToomas Soome \ $affix is either prefix (menuset_use_name is true) 254*22028508SToomas Soome \ or infix (menuset_use_name is false) 255*22028508SToomas Soome 256*22028508SToomas Soome menuset_use_name @ true = if 257*22028508SToomas Soome s" set buf=${affix}${type}_${var}[${x}][${y}]" 258*22028508SToomas Soome else 259*22028508SToomas Soome s" set buf=${type}set${affix}_${var}[${x}][${y}]" 260*22028508SToomas Soome then 261*22028508SToomas Soome evaluate 262*22028508SToomas Soome s" buf" getenv unsetenv 263*22028508SToomas Soome s" buf" unsetenv 264*22028508SToomas Soome; 265*22028508SToomas Soome 266*22028508SToomas Soome: menuset-loadansixyvar ( -- ) 267*22028508SToomas Soome s" set type=ansi" evaluate 268*22028508SToomas Soome menuset-loadxyvar 269*22028508SToomas Soome; 270*22028508SToomas Soome 271*22028508SToomas Soome: menuset-unloadansixyvar ( -- ) 272*22028508SToomas Soome s" set type=ansi" evaluate 273*22028508SToomas Soome menuset-unloadxyvar 274*22028508SToomas Soome; 275*22028508SToomas Soome 276*22028508SToomas Soome: menuset-loadmenuxyvar ( -- ) 277*22028508SToomas Soome s" set type=menu" evaluate 278*22028508SToomas Soome menuset-loadxyvar 279*22028508SToomas Soome; 280*22028508SToomas Soome 281*22028508SToomas Soome: menuset-unloadmenuxyvar ( -- ) 282*22028508SToomas Soome s" set type=menu" evaluate 283*22028508SToomas Soome menuset-unloadxyvar 284*22028508SToomas Soome; 285*22028508SToomas Soome 286*22028508SToomas Soome: menuset-setnum-namevar ( N -- C-Addr/U ) 287*22028508SToomas Soome 288*22028508SToomas Soome s" menuset_nameNNNNN" ( n -- n c-addr1 u1 ) \ variable basename 289*22028508SToomas Soome drop 12 ( n c-addr1 u1 -- n c-addr1 12 ) \ remove "NNNNN" 290*22028508SToomas Soome rot ( n c-addr1 12 -- c-addr1 12 n ) \ move number on top 291*22028508SToomas Soome 292*22028508SToomas Soome \ convert to string 293*22028508SToomas Soome n2s ( c-addr1 12 n -- c-addr1 12 c-addr2 u2 ) 294*22028508SToomas Soome 295*22028508SToomas Soome \ Combine strings 296*22028508SToomas Soome begin ( using u2 in c-addr2/u2 pair as countdown to zero ) 297*22028508SToomas Soome over ( c-addr1 u1 c-addr2 u2 -- continued below ) 298*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c-addr2 ) \ copy src-addr 299*22028508SToomas Soome c@ ( c-addr1 u1 c-addr2 u2 c-addr2 -- continued below ) 300*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c ) \ get next src-addr byte 301*22028508SToomas Soome 4 pick 4 pick 302*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c -- continued below ) 303*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 ) 304*22028508SToomas Soome \ get destination c-addr1/u1 pair 305*22028508SToomas Soome + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- cont. below ) 306*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c c-addr3 ) 307*22028508SToomas Soome \ combine dest-c-addr to get dest-addr for byte 308*22028508SToomas Soome c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below ) 309*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 ) 310*22028508SToomas Soome \ store the current src-addr byte into dest-addr 311*22028508SToomas Soome 312*22028508SToomas Soome 2swap 1+ 2swap \ increment u1 in destination c-addr1/u1 pair 313*22028508SToomas Soome swap 1+ swap \ increment c-addr2 in source c-addr2/u2 pair 314*22028508SToomas Soome 1- \ decrement u2 in the source c-addr2/u2 pair 315*22028508SToomas Soome 316*22028508SToomas Soome dup 0= \ time to break? 317*22028508SToomas Soome until 318*22028508SToomas Soome 319*22028508SToomas Soome 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) 320*22028508SToomas Soome \ drop temporary number-format conversion c-addr2/u2 321*22028508SToomas Soome; 322*22028508SToomas Soome 323*22028508SToomas Soome: menuset-checksetnum ( N -- ) 324*22028508SToomas Soome 325*22028508SToomas Soome \ 326*22028508SToomas Soome \ adjust input to be both positive and no-higher than 65535 327*22028508SToomas Soome \ 328*22028508SToomas Soome abs dup 65535 > if drop 65535 then ( n -- n ) 329*22028508SToomas Soome 330*22028508SToomas Soome \ 331*22028508SToomas Soome \ The next few blocks will determine if we should use the default 332*22028508SToomas Soome \ methodology (referencing the original numeric stack-input), or if- 333*22028508SToomas Soome \ instead $menuset_name{N} has been defined wherein we would then 334*22028508SToomas Soome \ use the value thereof as the prefix to every menu variable. 335*22028508SToomas Soome \ 336*22028508SToomas Soome 337*22028508SToomas Soome false menuset_use_name ! \ assume name is not set 338*22028508SToomas Soome 339*22028508SToomas Soome menuset-setnum-namevar 340*22028508SToomas Soome \ 341*22028508SToomas Soome \ We now have a string that is the assembled variable name to check 342*22028508SToomas Soome \ for... $menuset_name{N}. Let's check for it. 343*22028508SToomas Soome \ 344*22028508SToomas Soome 2dup ( c-addr1 u1 -- c-addr1 u1 c-addr1 u1 ) \ save a copy 345*22028508SToomas Soome getenv dup -1 <> if ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 c-addr2 u2 ) 346*22028508SToomas Soome \ The variable is set. Let's clean up the stack leaving only 347*22028508SToomas Soome \ its value for later use. 348*22028508SToomas Soome 349*22028508SToomas Soome true menuset_use_name ! 350*22028508SToomas Soome 2swap 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr2 u2 ) 351*22028508SToomas Soome \ drop assembled variable name, leave the value 352*22028508SToomas Soome else ( c-addr1 u1 c-addr1 u1 -- c-addr1 u1 -1 ) \ no such variable 353*22028508SToomas Soome \ The variable is not set. Let's clean up the stack leaving the 354*22028508SToomas Soome \ string [portion] representing the original numeric input. 355*22028508SToomas Soome 356*22028508SToomas Soome drop ( c-addr1 u1 -1 -- c-addr1 u1 ) \ drop -1 result 357*22028508SToomas Soome 12 - swap 12 + swap ( c-addr1 u1 -- c-addr2 u2 ) 358*22028508SToomas Soome \ truncate to original numeric stack-input 359*22028508SToomas Soome then 360*22028508SToomas Soome 361*22028508SToomas Soome \ 362*22028508SToomas Soome \ Now, depending on whether $menuset_name{N} has been set, we have 363*22028508SToomas Soome \ either the value thereof to be used as a prefix to all menu_* 364*22028508SToomas Soome \ variables or we have a string representing the numeric stack-input 365*22028508SToomas Soome \ to be used as a "set{N}" infix to the same menu_* variables. 366*22028508SToomas Soome \ 367*22028508SToomas Soome \ For example, if the stack-input is 1 and menuset_name1 is NOT set 368*22028508SToomas Soome \ the following variables will be referenced: 369*22028508SToomas Soome \ ansiset1_caption[x] -> ansi_caption[x] 370*22028508SToomas Soome \ ansiset1_caption[x][y] -> ansi_caption[x][y] 371*22028508SToomas Soome \ menuset1_acpi -> menu_acpi 372*22028508SToomas Soome \ menuset1_osconsole -> menu_osconsole 373*22028508SToomas Soome \ menuset1_caption[x] -> menu_caption[x] 374*22028508SToomas Soome \ menuset1_caption[x][y] -> menu_caption[x][y] 375*22028508SToomas Soome \ menuset1_command[x] -> menu_command[x] 376*22028508SToomas Soome \ menuset1_init -> ``evaluated'' 377*22028508SToomas Soome \ menuset1_init[x] -> menu_init[x] 378*22028508SToomas Soome \ menuset1_kernel -> menu_kernel 379*22028508SToomas Soome \ menuset1_keycode[x] -> menu_keycode[x] 380*22028508SToomas Soome \ menuset1_options -> menu_options 381*22028508SToomas Soome \ menuset1_optionstext -> menu_optionstext 382*22028508SToomas Soome \ menuset1_reboot -> menu_reboot 383*22028508SToomas Soome \ toggledset1_ansi[x] -> toggled_ansi[x] 384*22028508SToomas Soome \ toggledset1_text[x] -> toggled_text[x] 385*22028508SToomas Soome \ otherwise, the following variables are referenced (where {name} 386*22028508SToomas Soome \ represents the value of $menuset_name1 (given 1 as stack-input): 387*22028508SToomas Soome \ {name}ansi_caption[x] -> ansi_caption[x] 388*22028508SToomas Soome \ {name}ansi_caption[x][y] -> ansi_caption[x][y] 389*22028508SToomas Soome \ {name}menu_acpi -> menu_acpi 390*22028508SToomas Soome \ {name}menu_caption[x] -> menu_caption[x] 391*22028508SToomas Soome \ {name}menu_caption[x][y] -> menu_caption[x][y] 392*22028508SToomas Soome \ {name}menu_command[x] -> menu_command[x] 393*22028508SToomas Soome \ {name}menu_init -> ``evaluated'' 394*22028508SToomas Soome \ {name}menu_init[x] -> menu_init[x] 395*22028508SToomas Soome \ {name}menu_kernel -> menu_kernel 396*22028508SToomas Soome \ {name}menu_keycode[x] -> menu_keycode[x] 397*22028508SToomas Soome \ {name}menu_options -> menu_options 398*22028508SToomas Soome \ {name}menu_optionstext -> menu_optionstext 399*22028508SToomas Soome \ {name}menu_reboot -> menu_reboot 400*22028508SToomas Soome \ {name}toggled_ansi[x] -> toggled_ansi[x] 401*22028508SToomas Soome \ {name}toggled_text[x] -> toggled_text[x] 402*22028508SToomas Soome \ 403*22028508SToomas Soome \ Note that menuset{N}_init and {name}menu_init are the initializers 404*22028508SToomas Soome \ for the entire menu (for wholly dynamic menus) opposed to the per- 405*22028508SToomas Soome \ menuitem initializers (with [x] afterward). The whole-menu init 406*22028508SToomas Soome \ routine is evaluated and not passed down to $menu_init (which 407*22028508SToomas Soome \ would result in double evaluation). By doing this, the initializer 408*22028508SToomas Soome \ can initialize the menuset before we transfer it to active-duty. 409*22028508SToomas Soome \ 410*22028508SToomas Soome 411*22028508SToomas Soome \ 412*22028508SToomas Soome \ Copy our affixation (prefix or infix depending on menuset_use_name) 413*22028508SToomas Soome \ to our buffer so that we can safely use the s-quote (s") buf again. 414*22028508SToomas Soome \ 415*22028508SToomas Soome menuset_affixbuf 0 2swap ( c-addr2 u2 -- c-addr1 0 c-addr2 u2 ) 416*22028508SToomas Soome begin ( using u2 in c-addr2/u2 pair as countdown to zero ) 417*22028508SToomas Soome over ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c-addr2 ) 418*22028508SToomas Soome c@ ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 c-addr2 u2 c ) 419*22028508SToomas Soome 4 pick 4 pick 420*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c -- continued below ) 421*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 ) 422*22028508SToomas Soome + ( c-addr1 u1 c-addr2 u2 c c-addr1 u1 -- continued below ) 423*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 c c-addr3 ) 424*22028508SToomas Soome c! ( c-addr1 u1 c-addr2 u2 c c-addr3 -- continued below ) 425*22028508SToomas Soome ( c-addr1 u1 c-addr2 u2 ) 426*22028508SToomas Soome 2swap 1+ 2swap \ increment affixbuf byte position/count 427*22028508SToomas Soome swap 1+ swap \ increment strbuf pointer (source c-addr2) 428*22028508SToomas Soome 1- \ decrement strbuf byte count (source u2) 429*22028508SToomas Soome dup 0= \ time to break? 430*22028508SToomas Soome until 431*22028508SToomas Soome 2drop ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 ) \ drop strbuf c-addr2/u2 432*22028508SToomas Soome 433*22028508SToomas Soome \ 434*22028508SToomas Soome \ Create a variable for referencing our affix data (prefix or infix 435*22028508SToomas Soome \ depending on menuset_use_name as described above). This variable will 436*22028508SToomas Soome \ be temporary and only used to simplify cmdbuf assembly. 437*22028508SToomas Soome \ 438*22028508SToomas Soome s" affix" setenv ( c-addr1 u1 -- ) 439*22028508SToomas Soome; 440*22028508SToomas Soome 441*22028508SToomas Soome: menuset-cleanup ( -- ) 442*22028508SToomas Soome s" type" unsetenv 443*22028508SToomas Soome s" var" unsetenv 444*22028508SToomas Soome s" x" unsetenv 445*22028508SToomas Soome s" y" unsetenv 446*22028508SToomas Soome s" affix" unsetenv 447*22028508SToomas Soome; 448*22028508SToomas Soome 449*22028508SToomas Soomeonly forth definitions also menusets-infrastructure 450*22028508SToomas Soome 451*22028508SToomas Soome: menuset-loadsetnum ( N -- ) 452*22028508SToomas Soome 453*22028508SToomas Soome menuset-checksetnum ( n -- ) 454*22028508SToomas Soome 455*22028508SToomas Soome \ 456*22028508SToomas Soome \ From here out, we use temporary environment variables to make 457*22028508SToomas Soome \ dealing with variable-length strings easier. 458*22028508SToomas Soome \ 459*22028508SToomas Soome \ menuset_use_name is true or false 460*22028508SToomas Soome \ $affix should be used appropriately w/respect to menuset_use_name 461*22028508SToomas Soome \ 462*22028508SToomas Soome 463*22028508SToomas Soome \ ... menu_init ... 464*22028508SToomas Soome s" set var=init" evaluate 465*22028508SToomas Soome menuset-loadmenuvar 466*22028508SToomas Soome 467*22028508SToomas Soome \ If menu_init was set by the above, evaluate it here-and-now 468*22028508SToomas Soome \ so that the remaining variables are influenced by its actions 469*22028508SToomas Soome s" menu_init" 2dup getenv dup -1 <> if 470*22028508SToomas Soome 2swap unsetenv \ don't want later menu-create to re-call this 471*22028508SToomas Soome evaluate 472*22028508SToomas Soome else 473*22028508SToomas Soome drop 2drop ( n c-addr u -1 -- n ) 474*22028508SToomas Soome then 475*22028508SToomas Soome 476*22028508SToomas Soome [char] 1 ( -- x ) \ Loop range ASCII '1' (49) to '8' (56) 477*22028508SToomas Soome begin 478*22028508SToomas Soome dup menuset_x tuck c! 1 s" x" setenv \ set loop iterator and $x 479*22028508SToomas Soome 480*22028508SToomas Soome s" set var=caption" evaluate 481*22028508SToomas Soome 482*22028508SToomas Soome \ ... menu_caption[x] ... 483*22028508SToomas Soome menuset-loadmenuxvar 484*22028508SToomas Soome 485*22028508SToomas Soome \ ... ansi_caption[x] ... 486*22028508SToomas Soome menuset-loadansixvar 487*22028508SToomas Soome 488*22028508SToomas Soome [char] 0 ( x -- x y ) \ Inner Loop ASCII '1' (48) to '9' (57) 489*22028508SToomas Soome begin 490*22028508SToomas Soome dup menuset_y tuck c! 1 s" y" setenv 491*22028508SToomas Soome \ set inner loop iterator and $y 492*22028508SToomas Soome 493*22028508SToomas Soome \ ... menu_caption[x][y] ... 494*22028508SToomas Soome menuset-loadmenuxyvar 495*22028508SToomas Soome 496*22028508SToomas Soome \ ... ansi_caption[x][y] ... 497*22028508SToomas Soome menuset-loadansixyvar 498*22028508SToomas Soome 499*22028508SToomas Soome 1+ dup 57 > ( x y -- y' 0|-1 ) \ increment and test 500*22028508SToomas Soome until 501*22028508SToomas Soome drop ( x y -- x ) 502*22028508SToomas Soome 503*22028508SToomas Soome \ ... menu_command[x] ... 504*22028508SToomas Soome s" set var=command" evaluate 505*22028508SToomas Soome menuset-loadmenuxvar 506*22028508SToomas Soome 507*22028508SToomas Soome \ ... menu_init[x] ... 508*22028508SToomas Soome s" set var=init" evaluate 509*22028508SToomas Soome menuset-loadmenuxvar 510*22028508SToomas Soome 511*22028508SToomas Soome \ ... menu_keycode[x] ... 512*22028508SToomas Soome s" set var=keycode" evaluate 513*22028508SToomas Soome menuset-loadmenuxvar 514*22028508SToomas Soome 515*22028508SToomas Soome \ ... toggled_text[x] ... 516*22028508SToomas Soome s" set var=text" evaluate 517*22028508SToomas Soome menuset-loadtoggledxvar 518*22028508SToomas Soome 519*22028508SToomas Soome \ ... toggled_ansi[x] ... 520*22028508SToomas Soome s" set var=ansi" evaluate 521*22028508SToomas Soome menuset-loadtoggledxvar 522*22028508SToomas Soome 523*22028508SToomas Soome 1+ dup 56 > ( x -- x' 0|-1 ) \ increment iterator 524*22028508SToomas Soome \ continue if less than 57 525*22028508SToomas Soome until 526*22028508SToomas Soome drop ( x -- ) \ loop iterator 527*22028508SToomas Soome 528*22028508SToomas Soome \ ... menu_reboot ... 529*22028508SToomas Soome s" set var=reboot" evaluate 530*22028508SToomas Soome menuset-loadmenuvar 531*22028508SToomas Soome 532*22028508SToomas Soome \ ... menu_acpi ... 533*22028508SToomas Soome s" set var=acpi" evaluate 534*22028508SToomas Soome menuset-loadmenuvar 535*22028508SToomas Soome 536*22028508SToomas Soome \ ... menu_osconsole ... 537*22028508SToomas Soome s" set var=osconsole" evaluate 538*22028508SToomas Soome menuset-loadmenuvar 539*22028508SToomas Soome 540*22028508SToomas Soome \ ... menu_kmdb ... 541*22028508SToomas Soome s" set var=kmdb" evaluate 542*22028508SToomas Soome menuset-loadmenuvar 543*22028508SToomas Soome 544*22028508SToomas Soome \ ... menu_options ... 545*22028508SToomas Soome s" set var=options" evaluate 546*22028508SToomas Soome menuset-loadmenuvar 547*22028508SToomas Soome 548*22028508SToomas Soome \ ... menu_optionstext ... 549*22028508SToomas Soome s" set var=optionstext" evaluate 550*22028508SToomas Soome menuset-loadmenuvar 551*22028508SToomas Soome 552*22028508SToomas Soome menuset-cleanup 553*22028508SToomas Soome; 554*22028508SToomas Soome 555*22028508SToomas Soome: menusets-unset ( -- ) 556*22028508SToomas Soome 557*22028508SToomas Soome \ clean up BE menu internal variables 558*22028508SToomas Soome s" beansi_bootfs" unsetenv 559*22028508SToomas Soome s" beansi_current" unsetenv 560*22028508SToomas Soome s" beansi_page" unsetenv 561*22028508SToomas Soome s" beansi_pageof" unsetenv 562*22028508SToomas Soome s" bemenu_bootfs" unsetenv 563*22028508SToomas Soome s" bemenu_current" unsetenv 564*22028508SToomas Soome s" bemenu_page" unsetenv 565*22028508SToomas Soome s" bemenu_pageof" unsetenv 566*22028508SToomas Soome s" zfs_be_active" unsetenv 567*22028508SToomas Soome s" zfs_be_currpage" unsetenv 568*22028508SToomas Soome s" zfs_be_pages" unsetenv 569*22028508SToomas Soome 570*22028508SToomas Soome s" menuset_initial" unsetenv 571*22028508SToomas Soome 572*22028508SToomas Soome 1 begin 573*22028508SToomas Soome dup menuset-checksetnum ( n n -- n ) 574*22028508SToomas Soome 575*22028508SToomas Soome dup menuset-setnum-namevar ( n n -- n ) 576*22028508SToomas Soome unsetenv 577*22028508SToomas Soome 578*22028508SToomas Soome \ If the current menuset does not populate the first menuitem, 579*22028508SToomas Soome \ we stop completely. 580*22028508SToomas Soome 581*22028508SToomas Soome menuset_use_name @ true = if 582*22028508SToomas Soome s" set buf=${affix}menu_command[1]" 583*22028508SToomas Soome else 584*22028508SToomas Soome s" set buf=menuset${affix}_command[1]" 585*22028508SToomas Soome then 586*22028508SToomas Soome evaluate s" buf" getenv getenv -1 = if 587*22028508SToomas Soome drop ( n -- ) 588*22028508SToomas Soome s" buf" unsetenv 589*22028508SToomas Soome menuset-cleanup 590*22028508SToomas Soome exit 591*22028508SToomas Soome else 592*22028508SToomas Soome drop ( n c-addr2 -- n ) \ unused 593*22028508SToomas Soome then 594*22028508SToomas Soome 595*22028508SToomas Soome [char] 1 ( n -- n x ) \ Loop range ASCII '1' (49) to '8' (56) 596*22028508SToomas Soome begin 597*22028508SToomas Soome dup menuset_x tuck c! 1 s" x" setenv \ set $x to x 598*22028508SToomas Soome 599*22028508SToomas Soome s" set var=caption" evaluate 600*22028508SToomas Soome menuset-unloadmenuxvar 601*22028508SToomas Soome menuset-unloadmenuxvar 602*22028508SToomas Soome menuset-unloadansixvar 603*22028508SToomas Soome [char] 0 ( n x -- n x y ) \ Inner loop '0' to '9' 604*22028508SToomas Soome begin 605*22028508SToomas Soome dup menuset_y tuck c! 1 s" y" setenv 606*22028508SToomas Soome \ sets $y to y 607*22028508SToomas Soome menuset-unloadmenuxyvar 608*22028508SToomas Soome menuset-unloadansixyvar 609*22028508SToomas Soome 1+ dup 57 > ( n x y -- n x y' 0|-1 ) 610*22028508SToomas Soome until 611*22028508SToomas Soome drop ( n x y -- n x ) 612*22028508SToomas Soome s" set var=command" evaluate menuset-unloadmenuxvar 613*22028508SToomas Soome s" set var=init" evaluate menuset-unloadmenuxvar 614*22028508SToomas Soome s" set var=keycode" evaluate menuset-unloadmenuxvar 615*22028508SToomas Soome s" set var=root" evaluate menuset-unloadtypelessxvar 616*22028508SToomas Soome s" set var=text" evaluate menuset-unloadtoggledxvar 617*22028508SToomas Soome s" set var=ansi" evaluate menuset-unloadtoggledxvar 618*22028508SToomas Soome 619*22028508SToomas Soome 1+ dup 56 > ( x -- x' 0|-1 ) \ increment and test 620*22028508SToomas Soome until 621*22028508SToomas Soome drop ( n x -- n ) \ loop iterator 622*22028508SToomas Soome 623*22028508SToomas Soome s" set var=acpi" evaluate menuset-unloadmenuvar 624*22028508SToomas Soome s" set var=osconsole" evaluate menuset-unloadmenuvar 625*22028508SToomas Soome s" set var=kmdb" evaluate menuset-unloadmenuvar 626*22028508SToomas Soome s" set var=init" evaluate menuset-unloadmenuvar 627*22028508SToomas Soome s" set var=options" evaluate menuset-unloadmenuvar 628*22028508SToomas Soome s" set var=optionstext" evaluate menuset-unloadmenuvar 629*22028508SToomas Soome s" set var=reboot" evaluate menuset-unloadmenuvar 630*22028508SToomas Soome 631*22028508SToomas Soome 1+ dup 65535 > ( n -- n' 0|-1 ) \ increment and test 632*22028508SToomas Soome until 633*22028508SToomas Soome drop ( n' -- ) \ loop iterator 634*22028508SToomas Soome 635*22028508SToomas Soome s" buf" unsetenv 636*22028508SToomas Soome menuset-cleanup 637*22028508SToomas Soome; 638*22028508SToomas Soome 639*22028508SToomas Soomeonly forth definitions 640*22028508SToomas Soome 641*22028508SToomas Soome: menuset-loadinitial ( -- ) 642*22028508SToomas Soome s" menuset_initial" getenv dup -1 <> if 643*22028508SToomas Soome ?number 0<> if 644*22028508SToomas Soome menuset-loadsetnum 645*22028508SToomas Soome then 646*22028508SToomas Soome else 647*22028508SToomas Soome drop \ cruft 648*22028508SToomas Soome then 649*22028508SToomas Soome; 650